From b2f6a2ff290e9bea5c43c6add5103839fa6326ed Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 29 Oct 1988 00:07:15 +0000 Subject: [PATCH] Add expansion rules for predicates like `vector?', `char?', etc. that expand into code that the compiler can open code pretty well. Add new global variables `sf/default-syntax-table' and `sf/top-level-definitions', the latter being a list of names which should not be treated specially by `usual-integrations'. --- v7/src/sf/make.scm | 4 +- v7/src/sf/sf.pkg | 4 +- v7/src/sf/sf.sf | 24 ++++- v7/src/sf/toplev.scm | 33 +++++-- v7/src/sf/usiexp.scm | 214 +++++++++++++++++++++++++++++++++++++------ v7/src/sf/xform.scm | 59 ++++++------ v8/src/sf/make.scm | 4 +- v8/src/sf/toplev.scm | 33 +++++-- 8 files changed, 290 insertions(+), 85 deletions(-) diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 0ba89aaba..1aa05b9d4 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -39,4 +39,4 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg index 29262267a..538d95324 100644 --- a/v7/src/sf/sf.pkg +++ b/v7/src/sf/sf.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -61,8 +61,10 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/sf.sf b/v7/src/sf/sf.sf index 0147ee021..edee23d0a 100644 --- a/v7/src/sf/sf.sf +++ b/v7/src/sf/sf.sf @@ -1,6 +1,6 @@ #| -*-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 @@ -32,10 +32,24 @@ Technology nor of any adaptation thereof in any advertising, 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))) diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index c195dec93..8de895da1 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -65,10 +65,7 @@ Currently only the 68000 implementation needs this." (syntax-file input-string bin-string spec-string))) (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 @@ -87,7 +84,7 @@ Currently only the 68000 implementation needs this." (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) @@ -103,11 +100,20 @@ Currently only the 68000 implementation needs this." (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))))) ;;;; File Syntaxer @@ -117,6 +123,13 @@ Currently only the 68000 implementation needs this." (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 () @@ -341,7 +354,7 @@ Currently only the 68000 implementation needs this." (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") diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index d604dba7c..6ebedf1a5 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -275,7 +275,7 @@ MIT in each case. |# ;;;; 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")) @@ -287,43 +287,201 @@ MIT in each case. |# #| ;; 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)) ;;;; 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 diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index 269a5c152..0b27a7258 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -54,33 +54,39 @@ MIT in each case. |# ;;; 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) @@ -92,17 +98,16 @@ MIT in each case. |# (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 @@ -272,7 +277,7 @@ MIT in each case. |# (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) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index 6d67bd6a4..06e793f07 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -39,4 +39,4 @@ MIT in each case. |# (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 diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 75bd2a45c..b48a5edaf 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -65,10 +65,7 @@ Currently only the 68000 implementation needs this." (syntax-file input-string bin-string spec-string))) (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 @@ -87,7 +84,7 @@ Currently only the 68000 implementation needs this." (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) @@ -103,11 +100,20 @@ Currently only the 68000 implementation needs this." (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))))) ;;;; File Syntaxer @@ -117,6 +123,13 @@ Currently only the 68000 implementation needs this." (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 () @@ -341,7 +354,7 @@ Currently only the 68000 implementation needs this." (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") -- 2.25.1