/usr/lib/s9fes/package.scm is in scheme9 2010.11.13-2.
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 141 142 143 144 145 146 147 148 149 150 151 152 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (package <name> <option> ... <body>) ==> unspecific
;
; PACKAGE packages the definitions in its <body> in such a
; way that they are not visible outside of its body, i.e.
; the scope of each definition is the <body> of the package.
; There must be at least one definition in <body>.
;
; There may be any number of <option>s preceding the definitions
; in the <body> of PACKAGE. All options are lists with a symbol
; beginning with a #\: in their first positions. The following
; options exist:
;
; (:EXPORT symbol ...) lists the symbols to exported from the
; package. When the name X of a definition occurs in :EXPORTS, a
; symbol with the name <name>:X will be made visible outside of
; the package. That symbol will be bound to the same value as X
; inside of the package.
;
; (:IMPORT symbol ...) lists the symbols to imported into the
; package. A symbol that is being imported into a package may be
; redefined later outside of the package without affecting its
; binding inside of the package.
;
; (:MAKE-ALIASES) will create an alias named X for each exported
; symbol named <name>:X, i.e. it will allow to refer to an object
; defined in a package by the same name inside and outside of the
; package.
;
; Example: (begin
; (package bar
; (:export foo2 foo3)
; (:make-aliases)
; (define (foo-maker n x)
; (if (zero? n)
; (lambda ()
; x)
; (foo-maker
; (- n 1)
; (cons n x))))
; (define foo2 (foo-maker 2 '()))
; (define foo3 (foo-maker 3 '())))
; (list (bar:foo2) (foo3))) ==> ((1 2) (1 2 3))
(load-from-library "for-all.scm")
(load-from-library "and-letstar.scm")
(load-from-library "letrecstar.scm")
(load-from-library "setters.scm")
(define-syntax (package %name . %body)
(if (not (symbol? %name))
(error "package: expected name, got" %name))
(letrec
((options '())
(imports '())
(exports '())
(for-all-i
(lambda (p x)
(cond ((null? x)
#t)
((pair? x)
(and (p (car x))
(for-all-i p (cdr x))))
(else
(p x)))))
(decompose-definition
(lambda (x)
(and-let* ((_ (pair? x))
(_ (eq? 'define (car x)))
(_ (pair? (cdr x)))
(body (cddr x))
(_ (pair? body))
(head (cadr x))
(_ (or (symbol? head)
(and (pair? head)
(for-all-i symbol? head))))
(_ (or (not (symbol? head))
(= 1 (length body)))))
(if (symbol? head)
(list head (car body))
(list (car head) `(lambda ,(cdr head) ,@body))))))
(external
(lambda (x)
(string->symbol
(string-append (symbol->string %name)
":"
(symbol->string x)))))
(make-def
(lambda (name)
`(define ,(external name) #f)))
(make-set
(lambda (name)
`(set! ,(external name) ,name)))
(make-alias
(lambda (name)
`(define ,name ,(external name))))
(make-import
(lambda (name)
`(,name ,name)))
(option-symbol?
(lambda (x)
(and (symbol? x)
(char=? #\: (string-ref (symbol->string x) 0)))))
(assert-list-of-symbols
(lambda (who x)
(if (not (for-all symbol? x))
(error (string-append "package: "
who
": expected list of symbols, got")
x)))))
(let parse-opts ((opts %body))
(cond ((null? opts)
(error "package: missing body"))
((and (pair? opts)
(pair? (car opts))
(option-symbol? (caar opts)))
(case (caar opts)
((:make-aliases)
(push! ':make-aliases options))
((:import)
(assert-list-of-symbols ":import" (cdar opts))
(set! imports (cdar opts)))
((:export)
(assert-list-of-symbols ":export" (cdar opts))
(set! exports (cdar opts))))
(parse-opts (cdr opts)))
(else
(set! %body opts))))
(let loop ((body %body)
(defs '()))
(if (null? body)
(let ((names (filter (lambda (x)
(or (null? exports)
(memq x exports)))
(reverse! (map car defs)))))
`(begin ,@(map make-def names)
(let ,(map make-import imports)
(letrec*
,(reverse! defs)
,@(map make-set names)))
,@(if (memq ':make-aliases options)
(map make-alias names)
'())))
(let ((name/val (decompose-definition (car body))))
(cond ((not name/val)
(error "package: expected definition, got"
(car body)))
(else
(loop (cdr body) (cons name/val defs)))))))))
|