scsh-0.6/scheme/misc/separate.scm

141 lines
4.3 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; packages packages-internal scan compiler table
; syntactic vm-exposure signals locations fluids template
; closures types inline dump/restore
; environments
; Separate compilation
; Setting the get-location method isn't sufficient because it won't
; intercept locations in already existing structures (e.g. scheme)...
;
; cf. compile-structures in link.scm
; Hacking the environment lookup mechanism to modify bindings on the
; way out won't work, because it might cause denotation comparison to
; fail during macro expansion...
; So I think the best we can do is to maintain a location -> reference map.
; There may be many routes to any particular location, but we'll only
; be able to remember one of them.
; (Actually, we _could_ remember all of them and then check at load time to
; make sure that they all agree.)
; The filtered environment also ought to be passed to the scanner,
; because it caches looked-up bindings in nodes. The effect of not
; doing this is to get warning at compile time, and unbound variables
; at load time.
(define (compile-package-to-file p filename)
(let* ((table (make-table location-id))
(env (package->separate p table))
(stuff (scan-package p env))
(templates '()))
(for-each (lambda (filename+nodes)
(set! templates
(cons (compile-scanned-forms
(cdr filename+nodes)
p
(car filename+nodes)
(current-output-port)
env)
templates)))
stuff)
(call-with-output-file filename
(lambda (port)
(fasdump (reverse templates) p table port)))))
(define (package->separate p table)
(let ((cenv (package->environment p)))
(lambda (name)
(let ((probe (cenv name)))
(if (and (pair? probe)
(location? (cdr probe))
(not (table-ref table (cdr probe))))
(table-set! table
(cdr probe)
(cons (name->qualified name)
(let ((type (binding-type probe)))
(if (equal? type usual-variable-type)
#f
type)))))
probe))))
(define *level* 0)
(define (fasdump templates p table port)
(let* ((write-char (lambda (c)
(write-char c port)))
(dump (lambda (thing)
(dump thing write-char -1))))
(dump *level*)
(dump (map structure-name (package-opens p))) ;lose
(dump (map car (package-accesses p)))
(table-walk (lambda (loc qname+type)
(dump (location-id loc))
(dump qname+type))
table)
(dump '-)
(let-fluid $dump-index (lambda (loc)
(if (table-ref table loc)
(location-id loc)
(begin (warn "lose" loc) #f)))
(lambda ()
(dump templates)))))
(define (fasload filename name->structure)
(call-with-input-file filename
(lambda (port)
(let* ((read-char (lambda () (read-char port)))
(restore (lambda () (restore read-char)))
(table (make-table))
(level (restore)))
(if (not (equal? level *level*))
(warn "format revision level disagreement - try recompiling"
`(file: ,level current: ,*level*)))
(let* ((open-names (restore))
(access-names (restore))
(p (make-package (lambda () (map name->structure open-names))
(lambda ()
(map (lambda (name)
(cons name
(name->structure name)))
access-names))
#f #f filename '()
#f ;uid
#f))) ;name
(let loop ()
(let ((uid (restore)))
(if (not (eq? uid '-))
(let ((qname+type (restore)))
(table-set! table uid (reference->location qname+type p))
(loop)))))
(let-fluid $restore-index (lambda (id define?)
(table-ref table id))
(lambda ()
(let ((templates (restore)))
(for-each (lambda (template)
(if (not (template? template))
(error "lossage" template))
(invoke-closure (make-closure template
(package-uid p))))
templates))))
p)))))
(define (reference->location qname+type p)
(let* ((compile-time-type (or (cdr qname+type) usual-variable-type))
(name (qualified->name (car qname+type) p))
(binding (package-lookup p name)))
(if (pair? binding)
(let ((type (binding-type binding)))
(if (not (equal? type compile-time-type))
(warn "type inconsistency"
`(compile time: ,compile-time-type)
`(load time: ,type)))
(cdr binding))
(package-define! p name compile-time-type))))