#| -*-Scheme-*-
-$Id: make.scm,v 4.36 2000/03/16 17:29:55 cph Exp $
+$Id: make.scm,v 4.37 2001/07/19 18:25:22 cph Exp $
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; SCode Optimizer: System Construction
(package/system-loader "sf" '() 'QUERY)))
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))))
-(add-subsystem-identification! "SF" '(4 36))
\ No newline at end of file
+(add-subsystem-identification! "SF" '(4 37))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: pardec.scm,v 4.11 1999/01/02 06:06:43 cph Exp $
+$Id: pardec.scm,v 4.12 2001/07/19 18:24:33 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; SCode Optimizer: Parse Declarations
;;;; Main Entry Points
(define (declarations/parse block declarations)
- (make-declaration-set declarations
- (append-map (lambda (declaration)
- (parse-declaration block declaration))
- declarations)))
+ (let ((declarations (merge-usual-integrations declarations)))
+ (make-declaration-set declarations
+ (append-map (lambda (declaration)
+ (parse-declaration block declaration))
+ declarations))))
+
+(define (merge-usual-integrations declarations)
+ (let loop ((declarations declarations) (exclusions 'NONE) (other '()))
+ (if (pair? declarations)
+ (if (eq? (caar declarations) 'USUAL-INTEGRATIONS)
+ (loop (cdr declarations)
+ (if (eq? exclusions 'NONE)
+ (cdar declarations)
+ (append exclusions (cdar declarations)))
+ other)
+ (loop (cdr declarations)
+ exclusions
+ (cons (car declarations) other)))
+ (if (eq? exclusions 'NONE)
+ (reverse! other)
+ (cons `(USUAL-INTEGRATIONS ,@exclusions)
+ (reverse! other))))))
(define (declarations/make-null)
(make-declaration-set '() '()))
"#[(scode-optimizer declarations)declaration-set]"))
(constructor make-declaration-set)
(conc-name declaration-set/))
- (original false read-only true)
- (declarations false read-only true))
+ (original #f read-only #t)
+ (declarations #f read-only #t))
(define-structure (declaration
(type vector)
(conc-name declaration/))
;; OPERATION is the name of the operation that is to be performed by
;; this declaration.
- (operation false read-only true)
+ (operation #f read-only #t)
;; The variable that this declaration affects.
- (variable false read-only true)
+ (variable #f read-only #t)
;; The value associated with this declaration. The meaning of this
;; field depends on OPERATION.
- (value false read-only true)
+ (value #f read-only #t)
;; OVERRIDABLE? means that a user-defined variable of the same name
;; will override this declaration. It also means that this
;; declaration should not be written out to the ".ext" file.
- (overridable? false read-only true))
+ (overridable? #f read-only #t))
(define (make-declarations operation variables values overridable?)
(if (eq? values 'NO-VALUES)
(map (lambda (variable)
- (make-declaration operation variable false overridable?))
+ (make-declaration operation variable #f overridable?))
variables)
(map (lambda (variable value)
(make-declaration operation variable value overridable?))
(constructor
(lambda (operation)
(lambda (name value)
- (let ((variable (block/lookup-name block name false)))
+ (let ((variable (block/lookup-name block name #f)))
(if variable
(set! declarations
(cons (make-declaration operation
variable
value
- true)
+ #t)
declarations))
(set! remaining
(cons (vector operation name value)
(vector-ref remaining 0)
(variable/make&bind! top-level-block (vector-ref remaining 1))
(vector-ref remaining 2)
- true)))
+ #t)))
remaining))))
\f
(define (define-integration-declaration operation)
(define-declaration operation
(lambda (block names)
(make-declarations operation
- (block/lookup-names block names true)
+ (block/lookup-names block names #t)
'NO-VALUES
- false))))
+ #f))))
(define-integration-declaration 'INTEGRATE)
(define-integration-declaration 'INTEGRATE-OPERATOR)
name)
(make-integration-info
(copy/expression/extern block value))
- true))))))
+ #t))))))
externs))))
(append-map (lambda (specification)
(let ((value
specifications))))
(define (operations->external operations environment)
- (let ((block (block/make false false '())))
+ (let ((block (block/make #f #f '())))
(values
block
- (delq! false
+ (delq! #f
(operations/map-external operations
(lambda (operation variable value)
(let ((finish
(variable/final-value variable
environment
finish
- (lambda () false)))
+ (lambda () #f)))
((integration-info? value)
(finish (integration-info/expression value)))
((dumpable-expander? value)
(for-each (lambda (variable)
(if variable
(variable/can-ignore! variable)))
- (block/lookup-names block names false))
+ (block/lookup-names block names #f))
'()))
\f
;;;; Reductions and Expansions
(check-declaration-syntax 'REDUCE-OPERATOR reduction-rules)
(map (lambda (rule)
(make-declaration 'EXPAND
- (block/lookup-name block (car rule) true)
+ (block/lookup-name block (car rule) #t)
(make-dumpable-expander (reducer/make rule block)
`(REDUCE-OPERATOR ,rule))
- false))
+ #f))
reduction-rules)))
(define (check-declaration-syntax kind declarations)
'EXPAND
(let ((name (car replacement)))
(cond ((symbol? name)
- (block/lookup-name block name true))
+ (block/lookup-name block name #t))
((and (pair? name)
(eq? (car name) 'PRIMITIVE))
(make-primitive-procedure (cadr name)
(make-dumpable-expander
(replacement/make replacement block)
`(REPLACE-OPERATOR ,replacement))
- false))
+ #f))
replacements)))
\f
(define (make-dumpable-expander expander declaration)
block ;ignored
(map (lambda (expander)
(make-declaration 'EXPAND
- (block/lookup-name block (car expander) true)
+ (block/lookup-name block (car expander) #t)
(eval (cadr expander)
expander-evaluation-environment)
- false))
+ #f))
expanders)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff