/usr/share/scsh-0.6/misc/separate.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | ; 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))))
|