mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 12:00:21 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/debug.h
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm
This commit is contained in:
Andy Wingo 2012-01-30 19:59:08 +01:00
commit dfadcf85cb
45 changed files with 20479 additions and 19006 deletions
Download patch file Download diff file Expand all files Collapse all files

36
module/ice-9/boot-9.scm
View file

@ -389,8 +389,6 @@ If there is no handler at all, Guile prints an error and then exits."
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
(define syntax-local-binding #f)
(define syntax-locally-bound-identifiers #f)
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
@ -3821,12 +3819,44 @@ module '(ice-9 q) '(make-q q-length))}."
;;; Place the user in the guile-user module.
;;; SRFI-4 in the default environment. FIXME: we should figure out how
;;; to deprecate this.
;;;
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
;;; A few identifiers that need to be defined in this file are really
;;; internal implementation details. We shove them off into internal
;;; modules, removing them from the (guile) module.
;;;
(define-module (system syntax))
(let ()
(define (steal-bindings! from to ids)
(for-each
(lambda (sym)
(let ((v (module-local-variable from sym)))
(module-remove! from sym)
(module-add! to sym v)))
ids)
(module-export! to ids))
(steal-bindings! the-root-module (resolve-module '(system syntax))
'(syntax-local-binding
syntax-module
syntax-locally-bound-identifiers
syntax-session-id)))
;;; Place the user in the guile-user module.
;;;
;; Set filename to #f to prevent reload.
(define-module (guile-user)
#:autoload (system base compile) (compile compile-file)

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

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;; Copyright (C) 2009, 2010, 2011, 2012 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
@ -19,7 +19,12 @@
(use-modules (language tree-il)
(language tree-il optimize)
(language tree-il canonicalize)
(ice-9 pretty-print))
(ice-9 pretty-print)
(system syntax))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(set! syntax-session-id (lambda () "*"))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))

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

@ -425,7 +425,8 @@
(let ((x (eval x env)))
(if (and (procedure? x) (not (procedure-property x 'name)))
(set-procedure-property! x 'name name))
(define! name x)))
(define! name x)
(if #f #f)))
(('toplevel-set! (var-or-sym . x))
(variable-set!

251
module/ice-9/local-eval.scm Normal file
View file

@ -0,0 +1,251 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2012 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 local-eval)
#:use-module (ice-9 format)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (system base compile)
#:use-module (system syntax)
#:export (the-environment local-eval local-compile))
(define-record-type lexical-environment-type
(make-lexical-environment scope wrapper boxes patterns)
lexical-environment?
(scope lexenv-scope)
(wrapper lexenv-wrapper)
(boxes lexenv-boxes)
(patterns lexenv-patterns))
(set-record-type-printer!
lexical-environment-type
(lambda (e port)
(format port "#<lexical-environment ~S (~S bindings)>"
(syntax-module (lexenv-scope e))
(+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
(define-syntax syntax-object-of
(lambda (form)
(syntax-case form ()
((_ x) #`(quote #,(datum->syntax #'x #'x))))))
(define-syntax-rule (make-box v)
(case-lambda
(() v)
((x) (set! v x))))
(define (make-transformer-from-box id trans)
(set-procedure-property! trans 'identifier-syntax-box id)
trans)
(define-syntax-rule (identifier-syntax-from-box box)
(make-transformer-from-box
(syntax-object-of box)
(identifier-syntax (id (box))
((set! id x) (box x)))))
(define (unsupported-binding name)
(make-variable-transformer
(lambda (x)
(syntax-violation
'local-eval
"unsupported binding captured by (the-environment)"
x))))
(define (within-nested-ellipses id lvl)
(let loop ((s id) (n lvl))
(if (zero? n)
s
(loop #`(#,s (... ...)) (- n 1)))))
;; Analyze the set of bound identifiers IDS. Return four values:
;;
;; capture: A list of forms that will be emitted in the expansion of
;; `the-environment' to capture lexical variables.
;;
;; formals: Corresponding formal parameters for use in the lambda that
;; re-introduces those variables. These are temporary identifiers, and
;; as such if we have a nested `the-environment', there is no need to
;; capture them. (See the notes on nested `the-environment' and
;; proxies, below.)
;;
;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
;; the expression to be evaluated in forms that re-introduce the
;; variable. The forms will be nested so that the variable shadowing
;; semantics of the original form are maintained.
;;
;; patterns: A terrible hack. The issue is that for pattern variables,
;; we can't emit lexically nested with-syntax forms, like:
;;
;; (with-syntax ((foo 1)) (the-environment))
;; => (with-syntax ((foo 1))
;; ... #'(with-syntax ((foo ...)) ... exp) ...)
;;
;; The reason is that the outer "foo" substitutes into the inner "foo",
;; yielding something like:
;;
;; (with-syntax ((foo 1))
;; ... (with-syntax ((1 ...)) ...)
;;
;; Which ain't what we want. So we hide the information needed to
;; re-make the inner pattern binding form in the lexical environment
;; object, and then introduce those identifiers via another with-syntax.
;;
;;
;; There are four different kinds of lexical bindings: normal lexicals,
;; macros, displaced lexicals, and pattern variables. See the
;; documentation of syntax-local-binding for more info on these.
;;
;; We capture normal lexicals via `make-box', which creates a
;; case-lambda that can reference or set a variable. These get
;; re-introduced with an identifier-syntax.
;;
;; We can't capture macros currently. However we do recognize our own
;; macros that are actually proxying lexicals, so that nested
;; `the-environment' forms are possible. In that case we drill down to
;; the identifier for the already-existing box, and just capture that
;; box.
;;
;; And that's it: we skip displaced lexicals, and the pattern variables
;; are discussed above.
;;
(define (analyze-identifiers ids)
(define (mktmp)
(datum->syntax #'here (gensym "t ")))
(let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
(cond
((null? ids)
(values capture formals wrappers patterns))
(else
(let ((id (car ids)) (ids (cdr ids)))
(call-with-values (lambda () (syntax-local-binding id))
(lambda (type val)
(case type
((lexical)
(if (or-map (lambda (x) (bound-identifier=? x id)) formals)
(lp ids capture formals wrappers patterns)
(let ((t (mktmp)))
(lp ids
(cons #`(make-box #,id) capture)
(cons t formals)
(cons (lambda (x)
#`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
#,x))
wrappers)
patterns))))
((displaced-lexical)
(lp ids capture formals wrappers patterns))
((macro)
(let ((b (procedure-property val 'identifier-syntax-box)))
(if b
(lp ids (cons b capture) (cons b formals)
(cons (lambda (x)
#`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
#,x))
wrappers)
patterns)
(lp ids capture formals
(cons (lambda (x)
#`(let-syntax ((#,id (unsupported-binding '#,id)))
#,x))
wrappers)
patterns))))
((pattern-variable)
(let ((t (datum->syntax id (gensym "p ")))
(nested (within-nested-ellipses id (cdr val))))
(lp ids capture formals
(cons (lambda (x)
#`(with-syntax ((#,t '#,nested))
#,x))
wrappers)
;; This dance is to hide these pattern variables
;; from the expander.
(cons (list (datum->syntax #'here (syntax->datum id))
(cdr val)
t)
patterns))))
(else
(error "what" type val))))))))))
(define-syntax the-environment
(lambda (x)
(syntax-case x ()
((the-environment)
#'(the-environment the-environment))
((the-environment scope)
(call-with-values (lambda ()
(analyze-identifiers
(syntax-locally-bound-identifiers #'scope)))
(lambda (capture formals wrappers patterns)
(define (wrap-expression x)
(let lp ((x x) (wrappers wrappers))
(if (null? wrappers)
x
(lp ((car wrappers) x) (cdr wrappers)))))
(with-syntax (((f ...) formals)
((c ...) capture)
(((pname plvl pformal) ...) patterns)
(wrapped (wrap-expression #'(begin #f exp))))
#'(make-lexical-environment
#'scope
(lambda (exp pformal ...)
(with-syntax ((exp exp)
(pformal pformal)
...)
#'(lambda (f ...)
wrapped)))
(list c ...)
(list (list 'pname plvl #'pformal) ...)))))))))
(define (env-module e)
(cond
((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
((module? e) e)
(else (error "invalid lexical environment" e))))
(define (env-boxes e)
(cond
((lexical-environment? e) (lexenv-boxes e))
((module? e) '())
(else (error "invalid lexical environment" e))))
(define (local-wrap x e)
(cond
((lexical-environment? e)
(apply (lexenv-wrapper e)
(datum->syntax (lexenv-scope e) x)
(map (lambda (l)
(let ((name (car l))
(lvl (cadr l))
(scope (caddr l)))
(within-nested-ellipses (datum->syntax scope name) lvl)))
(lexenv-patterns e))))
((module? e) #`(lambda () #f #,x))
(else (error "invalid lexical environment" e))))
(define (local-eval x e)
"Evaluate the expression @var{x} within the lexical environment @var{e}."
(apply (eval (local-wrap x e) (env-module e))
(env-boxes e)))
(define* (local-compile x e #:key (opts '()))
"Compile and evaluate the expression @var{x} within the lexical
environment @var{e}."
(apply (compile (local-wrap x e) #:env (env-module e)
#:from 'scheme #:opts opts)
(env-boxes e)))

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

File diff suppressed because it is too large Load diff

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

@ -273,8 +273,11 @@
(lambda (x mod)
(primitive-eval x)))
(define-syntax-rule (gensym-hook)
(gensym))
;; Capture syntax-session-id before we shove it off into a module.
(define session-id
(let ((v (module-variable (current-module) 'syntax-session-id)))
(lambda ()
((variable-ref v)))))
(define put-global-definition-hook
(lambda (symbol type val)
@ -452,7 +455,7 @@
;; FIXME: use a faster gensym
(define-syntax-rule (build-lexical-var src id)
(gensym (string-append (symbol->string id) " ")))
(gensym (string-append (symbol->string id) "-")))
(define-structure (syntax-object expression wrap module))
@ -626,13 +629,8 @@
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define gen-label
(let ((i 0))
(lambda ()
(let ((n i))
;; FIXME: Use atomic ops.
(set! i (1+ n))
(number->string n 36)))))
(define (gen-label)
(string-append "l-" (session-id) (symbol->string (gensym "-"))))
(define gen-labels
(lambda (ls)
@ -661,7 +659,7 @@
(cons 'shift (wrap-subst w)))))
(define-syntax-rule (new-mark)
(gensym "m"))
(gensym (string-append "m-" (session-id) "-")))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally
@ -1079,7 +1077,7 @@
(call-with-values
(lambda ()
(syntax-type x r w (source-annotation x) ribcage mod #f))
(lambda (type value e w s mod)
(lambda (type value form e w s mod)
(case type
((define-form)
(let* ((id (wrap value w mod))
@ -1171,11 +1169,11 @@
(else
(list
(if (eq? m 'c&e)
(let ((x (expand-expr type value e r w s mod)))
(let ((x (expand-expr type value form e r w s mod)))
(top-level-eval-hook x mod)
(lambda () x))
(lambda ()
(expand-expr type value e r w s mod)))))))))
(expand-expr type value form e r w s mod)))))))))
(let ((exps (map (lambda (x) (x))
(reverse (parse body r w s m esew mod)))))
(if (null? exps)
@ -1214,8 +1212,8 @@
(syntax-violation 'eval-when "invalid situation" e
(car l))))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The
;; first two are described in the table below.
;; syntax-type returns seven values: type, value, form, e, w, s, and
;; mod. The first two are described in the table below.
;;
;; type value explanation
;; -------------------------------------------------------------------
@ -1244,10 +1242,11 @@
;; constant none self-evaluating datum
;; other none anything else
;;
;; For definition forms (define-form, define-syntax-parameter-form,
;; and define-syntax-form), e is the rhs expression. For all
;; others, e is the entire form. w is the wrap for e. s is the
;; source for the entire form. mod is the module for e.
;; form is the entire form. For definition forms (define-form,
;; define-syntax-form, and define-syntax-parameter-form), e is the
;; rhs expression. For all others, e is the entire form. w is the
;; wrap for both form and e. s is the source for the entire form.
;; mod is the module for both form and e.
;;
;; syntax-type expands macros and unwraps as necessary to get to one
;; of the forms above. It also parses definition forms, although
@ -1262,28 +1261,28 @@
(case type
((macro)
(if for-car?
(values type value e w s mod)
(values type value e e w s mod)
(syntax-type (expand-macro value e r w s rib mod)
r empty-wrap s rib mod #f)))
((global)
;; Toplevel definitions may resolve to bindings with
;; different names or in different modules.
(values type value value w s mod*))
(else (values type value e w s mod))))))
(values type value e value w s mod*))
(else (values type value e e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
(lambda () (syntax-type first r w s rib mod #t))
(lambda (ftype fval fe fw fs fmod)
(lambda (ftype fval fform fe fw fs fmod)
(case ftype
((lexical)
(values 'lexical-call fval e w s mod))
(values 'lexical-call fval e e w s mod))
((global)
;; If we got here via an (@@ ...) expansion, we need to
;; make sure the fmod information is propagated back
;; correctly -- hence this consing.
(values 'global-call (make-syntax-object fval w fmod)
e w s mod))
e e w s mod))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
@ -1292,23 +1291,24 @@
(lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?))))
((core)
(values 'core-form fval e w s mod))
(values 'core-form fval e e w s mod))
((local-syntax)
(values 'local-syntax-form fval e w s mod))
(values 'local-syntax-form fval e e w s mod))
((begin)
(values 'begin-form #f e w s mod))
(values 'begin-form #f e e w s mod))
((eval-when)
(values 'eval-when-form #f e w s mod))
(values 'eval-when-form #f e e w s mod))
((define)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-form #'name #'val w s mod))
(values 'define-form #'name e #'val w s mod))
((_ (name . args) e1 e2 ...)
(and (id? #'name)
(valid-bound-ids? (lambda-var-list #'args)))
;; need lambda here...
(values 'define-form (wrap #'name w mod)
(wrap e w mod)
(decorate-source
(cons #'lambda (wrap #'(args e1 e2 ...) w mod))
s)
@ -1316,38 +1316,39 @@
((_ name)
(id? #'name)
(values 'define-form (wrap #'name w mod)
(wrap e w mod)
#'(if #f #f)
empty-wrap s mod))))
((define-syntax)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-syntax-form #'name #'val w s mod))))
(values 'define-syntax-form #'name e #'val w s mod))))
((define-syntax-parameter)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-syntax-parameter-form #'name #'val w s mod))))
(values 'define-syntax-parameter-form #'name e #'val w s mod))))
(else
(values 'call #f e w s mod)))))))
(values 'call #f e e w s mod)))))))
((syntax-object? e)
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
(or (source-annotation e) s) rib
(or (syntax-object-module e) mod) for-car?))
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
((self-evaluating? e) (values 'constant #f e e w s mod))
(else (values 'other #f e e w s mod)))))
(define expand
(lambda (e r w mod)
(call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value e w s mod)
(expand-expr type value e r w s mod)))))
(lambda (type value form e w s mod)
(expand-expr type value form e r w s mod)))))
(define expand-expr
(lambda (type value e r w s mod)
(lambda (type value form e r w s mod)
(case type
((lexical)
(build-lexical-reference 'value s e value))
@ -1396,8 +1397,8 @@
(expand-sequence #'(e1 e2 ...) r w s mod)
(expand-void))))))
((define-form define-syntax-form define-syntax-parameter-form)
(syntax-violation #f "definition in expression context"
e (wrap value w mod)))
(syntax-violation #f "definition in expression context, where definitions are not allowed,"
(source-wrap form w s mod)))
((syntax)
(syntax-violation #f "reference to pattern variable outside syntax form"
(source-wrap e w s mod)))
@ -1541,7 +1542,7 @@
(let ((e (cdar body)) (er (caar body)))
(call-with-values
(lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
(lambda (type value e w s mod)
(lambda (type value form e w s mod)
(case type
((define-form)
(let ((id (wrap value w mod)) (label (gen-label)))
@ -2307,7 +2308,7 @@
((_ (head tail ...) val)
(call-with-values
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
(lambda (type value ee ww ss modmod)
(lambda (type value ee* ee ww ss modmod)
(case type
((module-ref)
(let ((val (expand #'val r w mod)))
@ -2605,47 +2606,11 @@
(set! syntax-source
(lambda (x) (source-annotation x)))
(set! syntax-local-binding
(lambda (id)
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(define (strip-anti-mark w)
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
;; output is from original text
(make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
;; output introduced by macro
(make-wrap ms (if rib (cons rib s) s)))))
(call-with-values (lambda ()
(resolve-identifier
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
(syntax-object-module id)
;; FIXME: come up with a better policy for
;; resolve-syntax-parameters
#t))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod))))
(else (values 'other #f)))))))))
(set! syntax-locally-bound-identifiers
(lambda (x)
(arg-check nonsymbol-id? x 'syntax-locally-bound-identifiers)
(locally-bound-identifiers (syntax-object-wrap x)
(syntax-object-module x))))
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
(map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
(set! free-identifier=?
(lambda (x y)
@ -2669,6 +2634,53 @@
(strip form empty-wrap)
(and subform (strip subform empty-wrap)))))
(let ()
(define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
(cdr (syntax-object-module id)))
(define (syntax-local-binding id)
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(define (strip-anti-mark w)
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
;; output is from original text
(make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
;; output introduced by macro
(make-wrap ms (if rib (cons rib s) s)))))
(call-with-values (lambda ()
(resolve-identifier
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
(syntax-object-module id)
;; FIXME: come up with a better policy for
;; resolve-syntax-parameters
#t))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
(arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
(locally-bound-identifiers (syntax-object-wrap id)
(syntax-object-module id)))
;; Using define! instead of set! to avoid warnings at
;; compile-time, after the variables are stolen away into (system
;; syntax). See the end of boot-9.scm.
;;
(define! 'syntax-module syntax-module)
(define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
;; $sc-dispatch expects an expression and a pattern. If the expression
;; matches the pattern a list of the matching expressions for each
;; "any" is returned. Otherwise, #f is returned. (This use of #f will