(define (rewrite-scode expression context)
(let ((expression
- (if (open-block? expression)
- (open-block-components expression unscan-defines)
+ (if (scode-open-block? expression)
+ (unscan-defines (scode-open-block-names expression)
+ (scode-open-block-declarations expression)
+ (scode-open-block-actions expression))
expression)))
(if (eq? context 'REPL-BUFFER)
(make-scode-sequence
(cond ((scode/constant? scode)
scode)
((scode/open-block? scode)
- (scode/open-block-components
- scode
- (lambda (names declarations body)
- (if (null? names)
- (scan-defines
- body
- (lambda (names declarations* body)
- (make-open-block names
- (append declarations declarations*)
- body)))
- scode))))
+ (let ((names (scode/open-block-names scode))
+ (declarations (scode/open-block-declarations scode))
+ (body (scode/open-block-actions scode)))
+ (if (null? names)
+ (scan-defines body
+ (lambda (names declarations* body)
+ (scode/make-open-block names
+ (append declarations
+ declarations*)
+ body)))
+ scode)))
(else
- (scan-defines scode make-open-block)))))
+ (scan-defines scode make-scode-open-block)))))
\f
;;;; Alternate Entry Points
(scode/make-directive
(if (null? *top-level-declarations*)
(canout-expr canout)
- (make-open-block '()
- *top-level-declarations*
- (canout-expr canout)))
+ (scode/make-open-block '()
+ *top-level-declarations*
+ (canout-expr canout)))
'(COMPILE-PROCEDURE)
expr)
true
(error "canonicalize/sequence: open block in bad context"
expr context))
(else
- (scode/open-block-components
- expr
- (lambda (names decls body)
- (fluid-let ((*top-level-declarations*
- (append decls *top-level-declarations*)))
- (let ((body (unscan-defines names decls body)))
- ((if (and (eq? context 'TOP-LEVEL)
- compiler:compress-top-level?
- (> (length names) 1))
- canonicalize/compressing
- canonicalize/expression)
- body
- bound
- context))))))))
+ (let ((names (scode/open-block-names expr))
+ (decls (scode/open-block-declarations expr))
+ (body (scode/open-block-actions expr)))
+ (fluid-let ((*top-level-declarations*
+ (append decls *top-level-declarations*)))
+ (let ((body (unscan-defines names decls body)))
+ ((if (and (eq? context 'TOP-LEVEL)
+ compiler:compress-top-level?
+ (> (length names) 1))
+ canonicalize/compressing
+ canonicalize/expression)
+ body
+ bound
+ context)))))))
\f
(define (%single-definition name value)
(scode/make-combination
declarations
(unscan-defines names '() body)))))
(if (scode/open-block? scode)
- (scode/open-block-components scode collect)
+ (collect (scode/open-block-names scode)
+ (scode/open-block-declarations scode)
+ (scode/open-block-actions scode))
(scan-defines scode collect))))
(lambda (variables declarations scode)
(set-block-bound-variables! block variables)
(cond ((scode/lambda? expression)
(process (scode/lambda-name expression)))
((scode/open-block? expression)
- (scode/open-block-components
- expression
- (lambda (names decls body)
- decls ; ignored
- (if (and (null? names) (scode/lambda? body))
- (process (scode/lambda-name body))
- (fail)))))
+ (let ((body (scode/open-block-actions expression)))
+ (if (and (null? (scode/open-block-names expression))
+ (scode/lambda? body))
+ (process (scode/lambda-name body))
+ (fail))))
(else
(fail)))))
((ENCLOSE)
(scode/make-delay make-scode-delay)
(scode/make-disjunction make-scode-disjunction)
(scode/make-lambda make-scode-lambda)
- (scode/make-open-block make-open-block)
+ (scode/make-open-block make-scode-open-block)
(scode/make-quotation make-scode-quotation)
(scode/make-sequence make-scode-sequence)
(scode/make-the-environment make-scode-the-environment)
(scode/make-unassigned? make-scode-unassigned?)
(scode/make-variable make-scode-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
+ (scode/open-block-actions scode-open-block-actions)
+ (scode/open-block-declarations scode-open-block-declarations)
+ (scode/open-block-names scode-open-block-names)
+ (scode/open-block? scode-open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
(scode/quotation-expression scode-quotation-expression)
(scode/make-delay make-scode-delay)
(scode/make-disjunction make-scode-disjunction)
(scode/make-lambda make-scode-lambda)
- (scode/make-open-block make-open-block)
+ (scode/make-open-block make-scode-open-block)
(scode/make-quotation make-scode-quotation)
(scode/make-sequence make-scode-sequence)
(scode/make-the-environment make-scode-the-environment)
(scode/make-unassigned? make-scode-unassigned?)
(scode/make-variable make-scode-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
+ (scode/open-block-actions scode-open-block-actions)
+ (scode/open-block-declarations scode-open-block-declarations)
+ (scode/open-block-names scode-open-block-names)
+ (scode/open-block? scode-open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
(scode/quotation-expression scode-quotation-expression)
(scode/make-delay make-scode-delay)
(scode/make-disjunction make-scode-disjunction)
(scode/make-lambda make-scode-lambda)
- (scode/make-open-block make-open-block)
+ (scode/make-open-block make-scode-open-block)
(scode/make-quotation make-scode-quotation)
(scode/make-sequence make-scode-sequence)
(scode/make-the-environment make-scode-the-environment)
(scode/make-unassigned? make-scode-unassigned?)
(scode/make-variable make-scode-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
+ (scode/open-block-actions scode-open-block-actions)
+ (scode/open-block-declarations scode-open-block-declarations)
+ (scode/open-block-names scode-open-block-names)
+ (scode/open-block? scode-open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
(scode/quotation-expression scode-quotation-expression)
(scode/make-delay make-scode-delay)
(scode/make-disjunction make-scode-disjunction)
(scode/make-lambda make-scode-lambda)
- (scode/make-open-block make-open-block)
+ (scode/make-open-block make-scode-open-block)
(scode/make-quotation make-scode-quotation)
(scode/make-sequence make-scode-sequence)
(scode/make-the-environment make-scode-the-environment)
(scode/make-unassigned? make-scode-unassigned?)
(scode/make-variable make-scode-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
+ (scode/open-block-actions scode-open-block-actions)
+ (scode/open-block-declarations scode-open-block-declarations)
+ (scode/open-block-names scode-open-block-names)
+ (scode/open-block? scode-open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
(scode/quotation-expression scode-quotation-expression)
body)))))
(define (transform-open-block transforms open-block)
- (open-block-components open-block
- (lambda (names declarations body)
- (make-open-block names declarations
- (transform-expression (remove-transforms transforms
- names)
- body)))))
+ (let ((names (scode-open-block-names open-block)))
+ (make-scode-open-block
+ names
+ (scode-open-block-declarations open-block)
+ (transform-expression (remove-transforms transforms names)
+ (scode-open-block-actions open-block)))))
(define (transform-definition transforms definition)
(let ((name (scode-definition-name definition))
(scode-walker/comment walker)))
(define (walk/sequence walker expression)
- (if (open-block? expression)
+ (if (scode-open-block? expression)
(scode-walker/open-block walker)
(scode-walker/sequence walker)))
lambda-body
lambda-name
lambda?
+ open-block-actions
+ open-block-declarations
+ open-block-names
+ open-block?
quotation-expression
quotation?
sequence-actions
delay
disjunction
lambda
+ open-block
quotation
sequence
the-environment
(scode-lambda-components *lambda
(lambda (name required optional rest auxiliary declarations body)
(receiver name required optional rest
- (make-open-block auxiliary declarations body)))))
+ (make-scode-open-block auxiliary declarations body)))))
(define (lambda-components** *lambda receiver)
(lambda-components* *lambda
default-tag))))
(define-primitive-predicate-method 'sequence
- (simple-alternative scode-sequence? open-block?))
+ (simple-alternative scode-sequence? scode-open-block?))
(define-primitive-predicate-method 'tagged-object
%tagged-object-tag)))
\ No newline at end of file
(files "scan")
(parent (runtime))
(export ()
- make-open-block
- open-block-actions
- open-block-components
- open-block-declarations
- open-block-names
- open-block?
+ make-scode-open-block
scan-defines
+ scode-open-block-actions
+ scode-open-block-declarations
+ scode-open-block-names
+ scode-open-block?
unscan-defines))
(define-package (runtime scode-walker)
;;; of those names, and a new sequence in which those definitions are
;;; replaced by assignments. UNSCAN-DEFINES will invert that.
-;;; The Open Block abstraction can be used to store scanned
-;;; definitions in code, which is extremely useful for code analysis
-;;; and transformation. The supplied procedures, MAKE-OPEN-BLOCK and
-;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
-;;; UNSCAN-DEFINES, respectively.
+;;; The Open Block abstraction can be used to store scanned definitions in code,
+;;; which is extremely useful for code analysis and transformation.
(define-integrable sequence-type
(ucode-type sequence))
((scan-loop expression receiver) '() '() null-sequence))
(define (scan-loop expression receiver)
- (cond ((open-block? expression) ; must come before SCODE-SEQUENCE? clause
+ (cond ((scode-open-block? expression) ; must come before SCODE-SEQUENCE? clause
(scan-loop
(%open-block-actions expression)
(lambda (names declarations body)
\f
;;;; Open Block
-(define (make-open-block names declarations actions)
+(define (make-scode-open-block names declarations actions)
(if (and (null? names)
(null? declarations))
actions
(define (%make-open-block-definition name)
(make-scode-definition name (make-unassigned-reference-trap)))
-(define (open-block? object)
+(define (scode-open-block? object)
(and (scode-sequence? object)
(let ((actions (scode-sequence-actions object)))
(and (open-block-descriptor? (car actions))
(every %open-block-definition-named?
names
(cdr actions))))))))
-(register-predicate! open-block? 'open-block '<= scode-sequence?)
+(register-predicate! scode-open-block? 'open-block '<= scode-sequence?)
(define (%open-block-definition-named? name expr)
(and (scode-definition? expr)
(eq? name (scode-definition-name expr))
(unassigned-reference-trap? (scode-definition-value expr))))
-(define (open-block-names open-block)
- (guarantee open-block? open-block 'open-block-names)
+(define (scode-open-block-names open-block)
+ (guarantee scode-open-block? open-block 'scode-open-block-names)
(%open-block-names open-block))
-(define (open-block-declarations open-block)
- (guarantee open-block? open-block 'open-block-declarations)
+(define (scode-open-block-declarations open-block)
+ (guarantee scode-open-block? open-block 'scode-open-block-declarations)
(%open-block-declarations open-block))
-(define (open-block-actions open-block)
- (guarantee open-block? open-block 'open-block-actions)
+(define (scode-open-block-actions open-block)
+ (guarantee scode-open-block? open-block 'scode-open-block-actions)
(%open-block-actions open-block))
-(define (open-block-components open-block receiver)
- (guarantee open-block? open-block 'open-block-components)
- (receiver (%open-block-names open-block)
- (%open-block-declarations open-block)
- (%open-block-actions open-block)))
-
(define (%open-block-descriptor open-block)
(car (scode-sequence-actions open-block)))
names
temps)))
(list
- (let ((body (scan-defines body make-open-block)))
- (if (open-block? body)
+ (let ((body (scan-defines body make-scode-open-block)))
+ (if (scode-open-block? body)
(output/let '() '() body)
body))))))))
(list (make-block-declaration declarations)
body))
body))
- make-open-block))
+ make-scode-open-block))
(define (output/definition name value)
(make-scode-definition name value))
(define (output/top-level-sequence declarations expressions)
(let ((declarations (apply append declarations))
- (make-open-block
+ (make-scode-open-block
(lambda (expressions)
- (scan-defines (make-scode-sequence expressions) make-open-block))))
+ (scan-defines (make-scode-sequence expressions)
+ make-scode-open-block))))
(if (pair? declarations)
- (make-open-block
+ (make-scode-open-block
(cons (make-block-declaration declarations)
(if (pair? expressions)
expressions
(list (output/unspecific)))))
(if (pair? expressions)
(if (pair? (cdr expressions))
- (make-open-block expressions)
+ (make-scode-open-block expressions)
(car expressions))
(output/unspecific)))))
(declare (ignore pattern))
(mark-local-bindings bound body mark-safe!)))))
- (define-cs-handler open-block?
+ (define-cs-handler scode-open-block?
(lambda (expression mark-safe!)
- (open-block-components expression
- (lambda (bound declarations body)
- (declare (ignore declarations))
- (mark-local-bindings bound body mark-safe!)))))
+ (mark-local-bindings (scode-open-block-names expression)
+ (scode-open-block-actions expression)
+ mark-safe!)))
(define-cs-handler scode-access?
(simple-subexpression scode-access-environment))
(map substitution bound)
(alpha-substitute substitution body))))))
- (define-as-handler open-block?
+ (define-as-handler scode-open-block?
(lambda (substitution expression)
- (open-block-components expression
- (lambda (bound declarations body)
- (make-open-block (map substitution bound)
- (map (lambda (declaration)
- (map-declaration-identifiers substitution
- declaration))
- declarations)
- (alpha-substitute substitution body))))))
+ (make-scode-open-block
+ (map substitution (scode-open-block-names expression))
+ (map (lambda (declaration)
+ (map-declaration-identifiers substitution declaration))
+ (scode-open-block-declarations expression))
+ (alpha-substitute substitution (scode-open-block-actions expression)))))
(define-as-handler scode-declaration?
(lambda (substitution expression)
(loop (cdr actions)))
'())))
-(define (unsyntax-OPEN-BLOCK-object environment open-block)
+(define (unsyntax-open-block-object environment open-block)
(if (eq? #t unsyntaxer:macroize?)
- (open-block-components open-block
- (lambda (auxiliary declarations expression)
- (unsyntax-object environment
- (unscan-defines auxiliary declarations expression))))
+ (unsyntax-object
+ environment
+ (unscan-defines (scode-open-block-names open-block)
+ (scode-open-block-declarations open-block)
+ (scode-open-block-actions open-block)))
(unsyntax-SEQUENCE-object environment open-block)))
(define (unsyntax-DELAY-object environment object)
(make-lambda-list required optional rest '()))))
(define (unsyntax-lambda-body environment body)
- (if (open-block? body)
- (open-block-components body
- (lambda (names declarations open-block-body)
- (unsyntax-lambda-body-sequence environment
- (unscan-defines names declarations open-block-body))))
+ (if (scode-open-block? body)
+ (unsyntax-lambda-body-sequence
+ environment
+ (unscan-defines (scode-open-block-names body)
+ (scode-open-block-declarations body)
+ (scode-open-block-actions body)))
(unsyntax-lambda-body-sequence environment body)))
(define (unsyntax-lambda-body-sequence environment body)
(cond ((null? bound-names)
expression)
((or (scode-definition? expression)
- (and (open-block? expression)
- (open-block-components expression
- (lambda (names declarations body)
- declarations body
- (pair? names)))))
+ (and (scode-open-block? expression)
+ (pair? (scode-open-block-names expression))))
(error
"Can't perform definition in compiled-code environment:"
(unsyntax expression)))
(body (procedure/body procedure)))
(if (open-block? body)
(cgen-open-block body)
- (make-open-block
+ (make-scode-open-block
'()
(maybe-flush-declarations (block/declarations block))
(cgen/expression (list block) body)))))))
(define (cgen-open-block expression)
(let ((block (open-block/block expression)))
- (make-open-block
+ (make-scode-open-block
(map variable/name (open-block/variables expression))
(maybe-flush-declarations (block/declarations block))
(make-scode-sequence
((null? actions) (error "Extraneous auxiliaries"))
((eq? (car actions) open-block/value-marker)
(cons (make-scode-assignment (variable/name (car variables))
- (cgen/expression (list block) (car values)))
+ (cgen/expression (list block)
+ (car values)))
(loop (cdr variables) (cdr values) (cdr actions))))
(else
(cons (cgen/expression (list block) (car actions))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme 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
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SCode Optimizer: Global Imports
-;;; package: (scode-optimizer global-imports)
-
-(declare (usual-integrations))
-
-(define scode-open-block? open-block?)
\ No newline at end of file
(import (runtime microcode-tables)
microcode-type/code->name))
-(define-package (scode-optimizer global-imports)
- (files "gimprt")
- (parent ())
- (export (scode-optimizer)
- scode-open-block?))
-
(define-package (scode-optimizer top-level)
(files "toplev")
(parent (scode-optimizer))
(begin
(if (not top-level?)
(error "Open blocks allowed only at top level:" expression))
- (call-with-values
- (lambda () (open-block-components expression values))
- (lambda (auxiliary declarations body)
- (if (not (assq 'USUAL-INTEGRATIONS declarations))
- (ui-warning))
- (transform/open-block* expression
- block
- environment
- auxiliary
- declarations
- body))))
+ (let ((declarations (scode-open-block-declarations expression)))
+ (if (not (assq 'USUAL-INTEGRATIONS declarations))
+ (ui-warning))
+ (transform/open-block* expression
+ block
+ environment
+ (scode-open-block-names expression)
+ declarations
+ (scode-open-block-actions expression))))
(transform/expression block environment expression)))))
(define (ui-warning)
variables))
\f
(define (transform/open-block block environment expression)
- (call-with-values (lambda () (open-block-components expression values))
- (lambda (auxiliary declarations body)
- (transform/open-block* expression
- (block/make block true '())
- environment
- auxiliary
- declarations
- body))))
+ (transform/open-block* expression
+ (block/make block true '())
+ environment
+ (scode-open-block-names expression)
+ (scode-open-block-declarations expression)
+ (scode-open-block-actions expression)))
(define (transform/open-block* expression block environment auxiliary
declarations body)
(define (transform/procedure-body block environment expression)
(if (scode-open-block? expression)
- (open-block-components expression
- (lambda (auxiliary declarations body)
- (if (null? auxiliary)
- (begin (set-block/declarations!
- block
- (declarations/parse block declarations))
- (transform/expression block environment body))
- (transform/open-block block environment expression))))
+ (if (null? (scode-open-block-names expression))
+ (begin
+ (set-block/declarations!
+ block
+ (declarations/parse block
+ (scode-open-block-declarations expression)))
+ (transform/expression block
+ environment
+ (scode-open-block-actions expression)))
+ (transform/open-block block environment expression))
(transform/expression block environment expression)))
(define (transform/definition block environment expression)
projects / mit-scheme.git / commitdiff