#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.5 1988/06/13 12:29:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.6 1988/10/29 00:06:53 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 5 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 6 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.1 1988/06/13 12:28:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.2 1988/10/29 00:06:57 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(export ()
sf
sf/add-file-declarations!
+ sf/default-syntax-table
sf/set-default-syntax-table!
sf/set-file-syntax-table!
+ sf/top-level-definitions
sfu?)
(export (scode-optimizer)
integrate/procedure
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.sf,v 4.2 1988/10/12 06:27:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.sf,v 4.3 1988/10/29 00:07:01 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-(sf/set-default-syntax-table! system-global-syntax-table)
-(sf-conditionally "object")
-(sf-conditionally "lsets")
-(sf-directory ".")
+(fluid-let ((sf/default-syntax-table system-global-syntax-table) (sf/top-level-definitions
+ '(ACCESS?
+ ASSIGNMENT?
+ COMBINATION?
+ CONDITIONAL?
+ DECLARATION?
+ DELAY?
+ DISJUNCTION?
+ IN-PACKAGE?
+ OPEN-BLOCK?
+ PROCEDURE?
+ QUOTATION?
+ SEQUENCE?
+ THE-ENVIRONMENT?
+ VARIABLE?)))
+ (sf-conditionally "object")
+ (sf-conditionally "lsets")
+ (sf-directory "."))
;; Guarantee that the package modeller is loaded.
(if (not (name->package '(CROSS-REFERENCE)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.1 1988/06/13 12:30:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(syntax-file input-string bin-string spec-string)))
\f
(define (sf/set-default-syntax-table! syntax-table)
- (if (not (or (false? syntax-table)
- (syntax-table? syntax-table)))
- (error "Illegal syntax table" syntax-table))
- (set! default-syntax-table syntax-table))
+ (set! sf/default-syntax-table syntax-table))
(define (sf/set-file-syntax-table! pathname syntax-table)
(pathname-map/insert! file-info/syntax-table
(values (pathname-map/lookup file-info/syntax-table
pathname
identity-procedure
- (lambda () default-syntax-table))
+ (lambda () sf/default-syntax-table))
(file-info/get-declarations pathname))))
(define (file-info/get-declarations pathname)
(define file-info/syntax-table
(pathname-map/make))
-(define default-syntax-table
- false)
-
(define file-info/declarations
(pathname-map/make))
+
+(define sf/default-syntax-table
+ false)
+
+(define sf/top-level-definitions
+ '())
+
+(define (list-of-symbols? object)
+ (or (null? object)
+ (and (pair? object)
+ (symbol? (car object))
+ (list-of-symbols? (cdr object)))))
\f
;;;; File Syntaxer
(define sfu? false)
(define (syntax-file input-string bin-string spec-string)
+ (if (not (or (false? sf/default-syntax-table)
+ (syntax-table? sf/default-syntax-table)))
+ (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE"
+ sf/default-syntax-table))
+ (if (not (list-of-symbols? sf/top-level-definitions))
+ (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS"
+ sf/top-level-definitions))
(for-each (lambda (input-string)
(with-values
(lambda ()
(define (phase:transform scode)
(mark-phase "Transform")
- (transform/top-level scode))
+ (transform/top-level scode sf/top-level-definitions))
(define (phase:optimize block expression)
(mark-phase "Optimize")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.1 1988/06/13 12:30:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.2 1988/10/29 00:07:09 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; Miscellaneous
(define (make-string-expansion operands if-expanded if-not-expanded block)
- block ; ignored
+ block ;ignored
(let ((n (length operands)))
(cond ((zero? n)
(error "MAKE-STRING-EXPANSION: No arguments"))
#| ;; Not a desirable optimization with current compiler.
(define (identity-procedure-expansion operands if-expanded if-not-expanded
block)
- if-not-expanded block ; ignored
+ if-not-expanded block ;ignored
(if (not (= (length operands) 1))
(error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments"
(length operands)))
(if-expanded (car operands)))
|#
+
+(define (type-test-expansion type-name)
+ (let ((type (microcode-type type-name)))
+ (lambda (operands if-expanded if-not-expanded block)
+ if-not-expanded block ;ignored
+ (let ((n-operands (length operands)))
+ (if (not (= n-operands 1))
+ (error "TYPE-TEST-EXPANSION: wrong number of arguments"
+ n-operands)))
+ (if-expanded
+ (make-combination object-type?
+ (list (constant/make type) (car operands)))))))
+
+(define char?-expansion (type-test-expansion 'CHARACTER))
+(define vector?-expansion (type-test-expansion 'VECTOR))
+(define weak-pair?-expansion (type-test-expansion 'WEAK-CONS))
+
+(define compiled-code-address?-expansion (type-test-expansion 'COMPILED-ENTRY))
+(define compiled-code-block?-expansion
+ (type-test-expansion 'COMPILED-CODE-BLOCK))
+(define ic-environment?-expansion (type-test-expansion 'ENVIRONMENT))
+(define primitive-procedure?-expansion (type-test-expansion 'PRIMITIVE))
+(define promise?-expansion (type-test-expansion 'DELAYED))
+(define return-address?-expansion (type-test-expansion 'RETURN-ADDRESS))
+
+(define access?-expansion (type-test-expansion 'ACCESS))
+(define assignment?-expansion (type-test-expansion 'ASSIGNMENT))
+(define comment?-expansion (type-test-expansion 'COMMENT))
+(define conditional?-expansion (type-test-expansion 'CONDITIONAL))
+(define definition?-expansion (type-test-expansion 'DEFINITION))
+(define delay?-expansion (type-test-expansion 'DELAY))
+(define disjunction?-expansion (type-test-expansion 'DISJUNCTION))
+(define in-package?-expansion (type-test-expansion 'IN-PACKAGE))
+(define quotation?-expansion (type-test-expansion 'QUOTATION))
+(define the-environment?-expansion (type-test-expansion 'THE-ENVIRONMENT))
+(define variable?-expansion (type-test-expansion 'VARIABLE))
\f
;;;; Tables
(define usual-integrations/expansion-names
- '(= < > <= >= + - * / quotient remainder fix:quotient fix:remainder
- apply cons* list
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- second third fourth fifth sixth seventh eighth
- make-string
- ))
+ '(
+ *
+ +
+ -
+ /
+ <
+ <=
+ =
+ >
+ >=
+ access?
+ apply
+ assignment?
+ caaaar
+ caaadr
+ caaar
+ caadar
+ caaddr
+ caadr
+ caar
+ cadaar
+ cadadr
+ cadar
+ caddar
+ cadddr
+ caddr
+ cadr
+ cdaaar
+ cdaadr
+ cdaar
+ cdadar
+ cdaddr
+ cdadr
+ cdar
+ cddaar
+ cddadr
+ cddar
+ cdddar
+ cddddr
+ cdddr
+ cddr
+ char?
+ comment?
+ compiled-code-address?
+ compiled-code-block?
+ conditional?
+ cons*
+ definition?
+ delay?
+ disjunction?
+ eighth
+ fifth
+ fix:quotient
+ fix:remainder
+ fourth
+ ic-environment?
+ in-package?
+ list
+ make-string
+ primitive-procedure?
+ promise?
+ quotation?
+ quotient
+ remainder
+ return-address?
+ second
+ seventh
+ sixth
+ the-environment?
+ third
+ variable?
+ vector?
+ weak-pair?
+ ))
(define usual-integrations/expansion-values
- (list =-expansion <-expansion >-expansion <=-expansion >=-expansion
- +-expansion --expansion *-expansion /-expansion
- quotient-expansion remainder-expansion
- fix:quotient-expansion fix:remainder-expansion
- apply*-expansion cons*-expansion list-expansion
- caar-expansion cadr-expansion cdar-expansion cddr-expansion
- caaar-expansion caadr-expansion cadar-expansion caddr-expansion
- cdaar-expansion cdadr-expansion cddar-expansion cdddr-expansion
- caaaar-expansion caaadr-expansion caadar-expansion caaddr-expansion
- cadaar-expansion cadadr-expansion caddar-expansion cadddr-expansion
- cdaaar-expansion cdaadr-expansion cdadar-expansion cdaddr-expansion
- cddaar-expansion cddadr-expansion cdddar-expansion cddddr-expansion
- second-expansion third-expansion fourth-expansion fifth-expansion
- sixth-expansion seventh-expansion eighth-expansion
- make-string-expansion
- ))
+ (list
+ *-expansion
+ +-expansion
+ --expansion
+ /-expansion
+ <-expansion
+ <=-expansion
+ =-expansion
+ >-expansion
+ >=-expansion
+ access?-expansion
+ apply*-expansion
+ assignment?-expansion
+ caaaar-expansion
+ caaadr-expansion
+ caaar-expansion
+ caadar-expansion
+ caaddr-expansion
+ caadr-expansion
+ caar-expansion
+ cadaar-expansion
+ cadadr-expansion
+ cadar-expansion
+ caddar-expansion
+ cadddr-expansion
+ caddr-expansion
+ cadr-expansion
+ cdaaar-expansion
+ cdaadr-expansion
+ cdaar-expansion
+ cdadar-expansion
+ cdaddr-expansion
+ cdadr-expansion
+ cdar-expansion
+ cddaar-expansion
+ cddadr-expansion
+ cddar-expansion
+ cdddar-expansion
+ cddddr-expansion
+ cdddr-expansion
+ cddr-expansion
+ char?-expansion
+ comment?-expansion
+ compiled-code-address?-expansion
+ compiled-code-block?-expansion
+ conditional?-expansion
+ cons*-expansion
+ definition?-expansion
+ delay?-expansion
+ disjunction?-expansion
+ eighth-expansion
+ fifth-expansion
+ fix:quotient-expansion
+ fix:remainder-expansion
+ fourth-expansion
+ ic-environment?-expansion
+ in-package?-expansion
+ list-expansion
+ make-string-expansion
+ primitive-procedure?-expansion
+ promise?-expansion
+ quotation?-expansion
+ quotient-expansion
+ remainder-expansion
+ return-address?-expansion
+ second-expansion
+ seventh-expansion
+ sixth-expansion
+ the-environment?-expansion
+ third-expansion
+ variable?-expansion
+ vector?-expansion
+ weak-pair?-expansion ))
(define usual-integrations/expansion-alist
(map cons
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 4.1 1988/06/13 12:30:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 4.2 1988/10/29 00:07:15 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
;;; same variable object. So, instead we intern them in GLOBAL-BLOCK,
;;; which never has any user defined names in it.
-(define try-deep-lookup?)
-
-(define (transform/top-level expression)
- (fluid-let ((try-deep-lookup? false))
- (let ((block (block/make (block/make false false) false)))
- (values block (transform/top-level-1 true block block expression)))))
+(define (transform/top-level expression shadowed-names)
+ (let ((block (block/make (block/make false false) false)))
+ (set-block/bound-variables!
+ block
+ (map (lambda (name) (variable/make block name '())) shadowed-names))
+ (values block (transform/top-level-1 true block block expression))))
(define (transform/recursive block top-level-block expression)
- (fluid-let ((try-deep-lookup? true))
- (transform/top-level-1 false block top-level-block expression)))
+ (transform/top-level-1 false block top-level-block expression))
+
+(define top-level?)
+(define global-block)
-(define (transform/top-level-1 top-level? block top-level-block expression)
- (fluid-let ((try-deep-lookup? (not top-level?))
+(define (transform/top-level-1 top? block top-level-block expression)
+ (fluid-let ((top-level? top?)
(global-block
(let block/global-parent ((block top-level-block))
(if (block/parent block)
(block/global-parent (block/parent block))
block))))
- (let ((environment (environment/make)))
- (cond ((not (scode-open-block? expression))
- (transform/expression block environment expression))
- ((not top-level?)
- (error "TRANSFORM/TOP-LEVEL-1: open blocks disallowed"
- expression))
- (else
- (open-block-components expression
- (transform/open-block* block environment)))))))
+ (let ((environment
+ (if top-level?
+ (environment/bind (environment/make)
+ (block/bound-variables block))
+ (environment/make))))
+ (if (scode-open-block? expression)
+ (begin
+ (if (not top-level?)
+ (error "TRANSFORM/TOP-LEVEL-1: open blocks disallowed"
+ expression))
+ (open-block-components expression
+ (transform/open-block* block environment)))
+ (transform/expression block environment expression)))))
(define (transform/expressions block environment expressions)
(map (lambda (expression)
(define (transform/expression block environment expression)
((scode-walk transform/dispatch expression) block environment expression))
-(define global-block)
-
(define (environment/make)
'())
(define (environment/lookup block environment name)
(let ((association (assq name environment)))
- (cond (association (cdr association))
- ((and try-deep-lookup?
- (block/lookup-name block name false)))
- (else (block/lookup-name global-block name true)))))
+ (if association
+ (cdr association)
+ (or (and (not top-level?)
+ (block/lookup-name block name false))
+ (block/lookup-name global-block name true)))))
(define (environment/bind environment variables)
(map* environment
(transform/quotation* (quotation-expression expression)))
(define (transform/quotation* expression)
- (with-values (lambda () (transform/top-level expression))
+ (with-values (lambda () (transform/top-level expression '()))
quotation/make))
(define (transform/sequence block environment expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.5 1988/06/13 12:29:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.6 1988/10/29 00:06:53 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 5 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 6 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.1 1988/06/13 12:30:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.2 1988/10/29 00:07:04 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(syntax-file input-string bin-string spec-string)))
\f
(define (sf/set-default-syntax-table! syntax-table)
- (if (not (or (false? syntax-table)
- (syntax-table? syntax-table)))
- (error "Illegal syntax table" syntax-table))
- (set! default-syntax-table syntax-table))
+ (set! sf/default-syntax-table syntax-table))
(define (sf/set-file-syntax-table! pathname syntax-table)
(pathname-map/insert! file-info/syntax-table
(values (pathname-map/lookup file-info/syntax-table
pathname
identity-procedure
- (lambda () default-syntax-table))
+ (lambda () sf/default-syntax-table))
(file-info/get-declarations pathname))))
(define (file-info/get-declarations pathname)
(define file-info/syntax-table
(pathname-map/make))
-(define default-syntax-table
- false)
-
(define file-info/declarations
(pathname-map/make))
+
+(define sf/default-syntax-table
+ false)
+
+(define sf/top-level-definitions
+ '())
+
+(define (list-of-symbols? object)
+ (or (null? object)
+ (and (pair? object)
+ (symbol? (car object))
+ (list-of-symbols? (cdr object)))))
\f
;;;; File Syntaxer
(define sfu? false)
(define (syntax-file input-string bin-string spec-string)
+ (if (not (or (false? sf/default-syntax-table)
+ (syntax-table? sf/default-syntax-table)))
+ (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE"
+ sf/default-syntax-table))
+ (if (not (list-of-symbols? sf/top-level-definitions))
+ (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS"
+ sf/top-level-definitions))
(for-each (lambda (input-string)
(with-values
(lambda ()
(define (phase:transform scode)
(mark-phase "Transform")
- (transform/top-level scode))
+ (transform/top-level scode sf/top-level-definitions))
(define (phase:optimize block expression)
(mark-phase "Optimize")
projects / mit-scheme.git / commitdiff