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
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Miniature package system. This links mini-eval up to the output of
; the package reifier.
(define (package names locs get-location uid) ;Reified package
(lambda (name)
(let loop ((i (- (vector-length names) 1)))
(if (< i 0)
(assertion-violation 'package "unbound" name)
(if (eq? name (vector-ref names i))
(contents (get-location (vector-ref locs i)))
(loop (- i 1)))))))
(define (make-simple-package opens foo1 foo2 name)
(define bindings
(list (cons '%%define%%
(lambda (name val)
(set! bindings (cons (cons name val) bindings))))))
(lambda (name)
(let ((probe (assq name bindings)))
(if probe
(cdr probe)
(let loop ((opens opens))
(if (null? opens)
(assertion-violation 'make-simple-package "unbound" name)
(if (memq name (structure-interface (car opens)))
((structure-package (car opens)) name)
(loop (cdr opens)))))))))
; Structures
(define (make-structure package interface . name-option)
(cons package (vector->list interface)))
(define structure-interface cdr)
(define structure-package car)
; Things used by reification forms
(define (operator name type-exp)
`(operator ,name ,type-exp))
(define (simple-interface names type) names)
; Etc.
(define (transform . rest) (cons 'transform rest))
(define (usual-transform . rest)
(cons 'usual-transform rest))
(define (transform-for-structure-ref . rest)
(cons 'transform-for-structure-ref rest))
(define (inline-transform . rest)
(cons 'inline-transform rest))
(define (primop . rest)
(cons 'primop rest))
(define (package-define-static! package name op) 'lose)
; --------------------
; ???
; (define (integrate-all-primitives! . rest) 'lose)
;(define (package-lookup p name)
; ((p '%%lookup-operator%%) name))
;(define (package-ensure-defined! p name)
; (package-define! p name (make-location 'defined name)))
|
