(declare (usual-integrations))
\f
(define (make-library-db name)
- (let ((table (make-equal-hash-table)))
+ (let loop ((table (make-equal-hash-table)))
(define (has? name)
(hash-table-exists? table name))
(define (get-all)
(hash-table-values table))
+ (define (get-copy)
+ (loop (hash-table-copy table)))
+
(define (summarize-self)
(list name))
(define this
(bundle library-db?
- has? get put! get-names get-all
+ has? get put! get-names get-all get-copy
summarize-self describe-self))
this))
(define library-db?
(make-bundle-predicate 'library-database))
+
+(define (copy-library-db db)
+ (guarantee library-db? db 'copy-library-db)
+ (db 'get-copy))
\f
(define (make-library name . keylist)
(if name
(library-import-to e2))))
(define (library-import->list import)
- (list (library-import-from-library import)
- (library-import-from import)
- (library-import-to import)))
+ (cons* (library-import-from-library import)
+ (library-import-from import)
+ (if (eq? (library-import-from import) (library-import-to import))
+ '()
+ (list (library-import-to import)))))
(define (list->library-import list)
- (make-library-import (car list)
- (cadr list)
- (caddr list)))
+ (apply make-library-import list))
(define (library-imports-from imports)
(delete-duplicates (map library-import-from-library imports)
(library-export-to e2))))
(define (library-export->list export)
- (list (library-export-from export)
- (library-export-to export)))
+ (cons (library-export-from export)
+ (if (eq? (library-export-from export) (library-export-to export))
+ '()
+ (list (library-export-to export)))))
(define (list->library-export list)
- (make-library-export (car list) (cadr list)))
+ (apply make-library-export list))
(define-print-method library-export?
(standard-print-method 'library-export
(lambda (library)
(library 'get key)))
+(define library-bound-names (library-accessor 'bound-names))
(define library-contents (library-accessor 'contents))
(define library-environment (library-accessor 'environment))
(define library-exporter (library-accessor 'exporter))
(define library-filename (library-accessor 'filename))
(define library-imports (library-accessor 'imports))
(define library-imports-environment (library-accessor 'imports-environment))
+(define library-imports-used (library-accessor 'imports-used))
(define library-name (library-accessor 'name))
(define library-parsed-contents (library-accessor 'parsed-contents))
(define library-parsed-imports (library-accessor 'parsed-imports))
+(define library-scode (library-accessor 'scode))
(define library-syntaxed-contents (library-accessor 'syntaxed-contents))
\ No newline at end of file
\f
;;;; Syntax
-(define-automatic-property 'scode '(name imports exports contents)
+(define-automatic-property 'scode
+ '(name imports-used exports bound-names contents)
#f
- (lambda (name imports exports contents)
+ (lambda (name imports exports bound-names contents)
(make-scode-declaration
- `(target-metadata
- (library (name ,name)
- (imports ,(map library-import->list imports))
- (exports ,(map library-export->list exports))))
+ `((target-metadata
+ (library (name ,name)
+ (imports ,@(map library-import->list imports))
+ (exports ,@(map library-export->list exports))
+ (bound-names ,@bound-names))))
(make-scode-quotation contents))))
(define (eval-r7rs-source source db)
(scode-eval (library-contents program)
(library-environment program)))))
-(define-automatic-property 'contents
+(define-automatic-property '(contents bound-names imports-used)
'(parsed-contents imports exports imports-environment)
#f
(lambda (contents imports exports env)
(if (not (lset<= eq? free imports-to))
(warn "Library has free references not provided by imports:"
(lset-difference eq? free imports-to))))
- body)))
+ (values body
+ bound
+ (filter (lambda (import)
+ (memq (library-import-to import) free))
+ imports)))))
(define (expand-contents contents)
(append-map (lambda (directive)
(define (standard-library-exports name)
(cdr (assoc name standard-libraries)))
+;; Filters the given imports to find those that are equivalent to global
+;; variables, and for each one returns a pair of the "to" identifier and the
+;; corresponding global identifier. For now this is greatly simplified by
+;; knowing that all standard libraries use global variables, but this will need
+;; to be adapted when there are libraries that don't.
+(define (standard-library-globals import-lists)
+ (filter-map (lambda (import-list)
+ (let ((import (list->library-import import-list)))
+ (let ((p
+ (assoc (library-import-from-library import)
+ standard-libraries)))
+ (and p
+ (memq (library-import-from import)
+ (cdr p))
+ (cons (library-import-to import)
+ (library-import-from import))))))
+ import-lists))
+
(define (define-standard-library name exports)
(let ((p (assoc name standard-libraries)))
(if p
(define-package (runtime library database)
(files "library-database")
(parent (runtime library))
+ (export (runtime)
+ copy-library-db
+ library-scode)
(export (runtime library)
define-automatic-property
library-contents
(files "library-parser")
(parent (runtime library))
(export (runtime)
- read-r7rs-source)
+ r7rs-source-program
+ r7rs-source-libraries
+ r7rs-source?
+ read-r7rs-source
+ register-r7rs-source!)
(export (runtime library)
library-name=?
library-name?
parsed-import-library
parse-define-library-form
parse-import-form
- parse-import-set
- r7rs-source-program
- r7rs-source-libraries
- r7rs-source?
- register-r7rs-source!))
+ parse-import-set))
(define-package (runtime library standard)
(files "library-standard")
(parent (runtime library))
(export (runtime)
- host-library-db)
+ host-library-db
+ standard-library-globals)
(export (runtime library)
add-standard-libraries!
check-standard-libraries!
(let ((declarations (merge-usual-integrations declarations)))
(make-declaration-set declarations
(append-map (lambda (declaration)
- (parse-declaration block declaration))
+ (if (eq? (car declaration)
+ 'target-metadata)
+ '()
+ (parse-declaration block
+ declaration)))
declarations))))
(define (merge-usual-integrations declarations)
'global)))
remaining))))
\f
+;;; The corresponding case for R7RS is much simpler since the imports are
+;;; explicit.
+
+(define (r7rs-usual-integrations block imports)
+ (make-declaration-set '()
+ (let ((globals (standard-library-globals imports)))
+ (let ((constructor
+ (lambda (operation)
+ (lambda (name value)
+ (let ((global
+ (find (lambda (global)
+ (eq? (cdr global) name))
+ globals)))
+ (and global
+ (make-declaration operation
+ (block/lookup-name block
+ (car global)
+ #f)
+ value
+ 'global)))))))
+ (append (filter-map (constructor 'expand)
+ usual-integrations/expansion-names
+ usual-integrations/expansion-values)
+ (filter-map (constructor 'integrate)
+ usual-integrations/constant-names
+ usual-integrations/constant-values))))))
+\f
(define (define-integration-declaration operation)
(define-declaration operation
(lambda (block names)
(export ()
sf:enable-argument-deletion?
sf:enable-constant-folding?)
+ (import (runtime)
+ copy-library-db
+ current-load-library-db
+ library-scode
+ r7rs-source-libraries
+ r7rs-source-program
+ r7rs-source?
+ read-r7rs-source
+ register-r7rs-source!
+ standard-library-globals)
(import (runtime microcode-tables)
microcode-type/code->name))
(parent (scode-optimizer))
(export (scode-optimizer)
transform/top-level
+ transform/r7rs-library
transform/recursive))
(define-package (scode-optimizer integrate)
declarations/original
declarations/parse
known-declaration?
- operations->external))
+ operations->external
+ r7rs-usual-integrations))
(define-package (scode-optimizer copy)
(files "copy")
(*current-block-names* '()))
(call-with-values
(lambda ()
- (let ((operations (operations/make))
+ (let ((operations
+ (declarations/bind (operations/make)
+ (block/declarations block)))
(environment (environment/make)))
(if (open-block? expression)
(integrate/open-block operations environment expression)
- (let ((operations
- (declarations/bind operations
- (block/declarations block))))
- (values operations
- environment
- (integrate/expression operations
- environment
- expression))))))
+ (values operations
+ environment
+ (integrate/expression operations
+ environment
+ expression)))))
(lambda (operations environment expression)
(values operations environment
(quotation/make scode
(with-notification message do-it)))
(do-it))))))
-;; If not #F, should be a string file type. SF will pretty print
-;; the macro-expanded, but unoptimized file content to the output
-;; directory in a file with this extension.
-(define macroexpanded-pathname-type #f)
-
-;; If not #F, should be a string file type. SF will pretty print
-;; the optimized file content to the output directory in a file
-;; with this extension.
-(define optimized-pathname-type #f)
-
(define (sf/file->scode input-pathname output-pathname
environment declarations)
(fluid-let ((sf/default-externs-pathname
externs-pathname-type
'newest)))
(receive (expression externs-block externs)
- (integrate/file input-pathname
- (and output-pathname
- macroexpanded-pathname-type
- (pathname-new-type output-pathname
- macroexpanded-pathname-type))
- environment declarations)
+ (integrate/file input-pathname environment declarations)
(if output-pathname
(write-externs-file (pathname-new-type output-pathname
externs-pathname-type)
externs-block
externs))
- (if (and output-pathname
- optimized-pathname-type)
- (call-with-output-file
- (pathname-new-type output-pathname optimized-pathname-type)
- (lambda (port)
- (pp expression port))))
expression)))
(define externs-pathname-type
\f
;;;; Optimizer Top Level
-(define (integrate/file file-name macroexpanded-file-name environment declarations)
+(define (integrate/file file-name environment declarations)
(integrate/kernel
(lambda ()
- (let ((scode (phase:syntax (phase:read file-name)
- environment
- declarations)))
- (if macroexpanded-file-name
- (call-with-output-file macroexpanded-file-name
- (lambda (port)
- (pp scode port))))
- scode))))
+ (phase:syntax (phase:read file-name)
+ environment
+ declarations))))
(define (integrate/simple preprocessor input receiver)
(call-with-values
expression))))
(define (integrate/kernel get-scode)
- (receive (operations environment expression)
- (receive (block expression) (phase:transform (get-scode))
- (phase:optimize block expression))
- (phase:generate-scode operations environment expression)))
+ (let ((scode (get-scode)))
+ (if (list? scode)
+ (integrate/r7rs-libraries scode)
+ (integrate/kernel-1 (lambda () (phase:transform (get-scode)))))))
+
+(define (integrate/kernel-1 get-transformed)
+ (call-with-values
+ (lambda ()
+ (call-with-values get-transformed
+ phase:optimize))
+ phase:generate-scode))
(define (phase:read filename)
- (in-phase "Read" (lambda () (read-file filename))))
+ (in-phase "Read"
+ (lambda ()
+ (or (read-r7rs-source filename)
+ (read-file filename)))))
(define (phase:syntax s-expressions environment declarations)
(in-phase "Syntax"
(lambda ()
- (syntax* (if (null? declarations)
- s-expressions
- (cons (cons (close-syntax 'declare
- (runtime-environment->syntactic
- system-global-environment))
- declarations)
- s-expressions))
- environment))))
+ (if (r7rs-source? s-expressions)
+ (let ((db (copy-library-db (current-load-library-db))))
+ (register-r7rs-source! s-expressions db)
+ (map library-scode
+ (append (r7rs-source-libraries s-expressions)
+ (let ((program (r7rs-source-program s-expressions)))
+ (if program
+ (list program)
+ '())))))
+ (syntax* (if (null? declarations)
+ s-expressions
+ (cons (cons (close-syntax 'declare
+ (runtime-environment->syntactic
+ system-global-environment))
+ declarations)
+ s-expressions))
+ environment)))))
(define (phase:transform scode)
(in-phase "Transform"
(transform/top-level scode sf/top-level-definitions))))
(define (phase:optimize block expression)
- (in-phase "Optimize" (lambda () (integrate/top-level block expression))))
+ (in-phase "Optimize"
+ (lambda ()
+ (integrate/top-level block expression))))
(define (phase:generate-scode operations environment expression)
(in-phase "Generate SCode"
(receive (externs-block externs)
(operations->external operations environment)
(values (cgen/external expression) externs-block externs)))))
+\f
+(define (integrate/r7rs-libraries libraries)
+ (values (make-scode-sequence (map integrate/r7rs-library libraries))
+ #f
+ '()))
+
+(define (integrate/r7rs-library library)
+ (let ((text (scode-declaration-text library))
+ (expr (scode-declaration-expression library)))
+ (make-scode-declaration
+ text
+ (make-scode-quotation
+ (receive (optimized externs-block externs)
+ (integrate/kernel-1
+ (lambda ()
+ (phase:transform-r7rs (cdr (assq 'imports (cdar (cdar text))))
+ (scode-quotation-expression expr))))
+ (declare (ignore externs-block externs))
+ optimized)))))
+
+(define (phase:transform-r7rs imports scode)
+ (in-phase "Transform"
+ (lambda ()
+ (transform/r7rs-library imports scode))))
(define (in-phase name thunk)
(if (eq? sf:noisy? 'old-style)
(define (transform/recursive block top-level-block expression)
(transform/top-level-1 false top-level-block block expression))
+(define (transform/r7rs-library imports expression)
+ (let ((block (block/make #f #f '())))
+ (for-each (lambda (import)
+ (variable/make&bind! block
+ (if (pair? (cddr import))
+ (caddr import)
+ (cadr import))))
+ imports)
+ (set-block/declarations! block (r7rs-usual-integrations block imports))
+ (values block
+ (transform/top-level-1 'r7rs
+ block
+ (block/make block #t '())
+ expression))))
+
(define top-level?)
(define top-level-block)
(define root-block)
(if (not top-level?)
(error "Open blocks allowed only at top level:" expression))
(let ((declarations (scode-open-block-declarations expression)))
- (if (not (assq 'usual-integrations declarations))
+ (if (not (or (eq? tl? 'r7rs)
+ (assq 'usual-integrations declarations)))
(ui-warning))
(transform/open-block* expression
block
declarations
(scode-open-block-actions expression))))
(transform/expression block environment expression)))))
-
+\f
(define (ui-warning)
(for-each
(lambda (line)
projects / mit-scheme.git / commitdiff