-
Notifications
You must be signed in to change notification settings - Fork 0
/
require.scm
153 lines (124 loc) · 3.9 KB
/
require.scm
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
153
;;; Copyright 2016-2018 by Christian Jaeger <ch@christianjaeger.ch>
;;; This file is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License (GPL) as published
;;; by the Free Software Foundation, either version 2 of the License, or
;;; (at your option) any later version.
(require)
(export base-string.maybe-modulename
base-string.modulename
path-string.modulename
path-string.relation
require:include?
require:include-path?
#!optional ;; move? :
require:include-string?
scm-stripsuffix
simple-basename
scm-basename)
(define (scm-stripsuffix p)
(let ((len (string-length p)))
(if (and (> len 4)
(string=? (substring p (- len 4) len) ".scm"))
(substring p 0 (- len 4))
(error "not a path with suffix '.scm':" p))))
(define (simple-basename p)
(let ((len (string-length p)))
(let lp ((i (- len 1)))
(if (negative? i)
p
(let ((c (string-ref p i)))
(if (char=? c #\/)
(substring p (+ i 1) len)
(lp (- i 1))))))))
;; unlike (basename p ".scm"), this also complains for wrong suffix
(define (scm-basename p)
(simple-basename (scm-stripsuffix p)))
(define (require-decl.modulename v)
(cond ((symbol? v)
(source-code v))
((pair? v)
(source-code (car (source-code v))))
(else
(error "no match:" v))))
;; expect relative path, strip first level of folders. XX this is a
;; HACK to get rid of project folders; but local subfolders will be
;; stripped as well.
;; (define (path-string.modulename p) ;; -> symbol?
;; (let ((l (string-split (scm-stripsuffix p) #\/)))
;; (if (string=? (car l) "")
;; (error "need relative path, got:" p)
;; (strings-join (cdr l) "/"))))
;; ^ relies on unavailable dependencies
;; path-string: ending in .scm
;; base-string: with .scm stripped
;; returns #f if given s is absolute
(define (base-string.maybe-modulename s) ;; -> (maybe symbol?)
(let* ((len (string-length s))
(maybe-ifirst (let lp ((i 0))
(if (< i len)
(if (char=? (string-ref s i) #\/)
i
(lp (+ i 1)))
#f))))
(if maybe-ifirst
(if (zero? maybe-ifirst)
#f
(string->symbol (substring s (+ maybe-ifirst 1) len)))
(string->symbol s))))
(define (base-string.modulename s) ;; -> symbol?
(or (base-string.maybe-modulename s)
(error "need relative base string, got:" s)))
(define (path-string.modulename p) ;; -> symbol?
(or (base-string.maybe-modulename (scm-stripsuffix p))
(error "need relative path, got:" p)))
;; "...--include.scm" should never be expected to have (or checked
;; for) a require form
(define (require:include-string? str)
(let* ((len (string-length str)))
(and (> len 9)
(string=? (substring str (- len 9) len) "--include"))))
(define (require:include? sym)
(require:include-string? (symbol->string sym)))
(define (require:include-path? path)
(require:include-string? (scm-stripsuffix path)))
(define modules-without-require-forms
'( ;; cj-source
;; define-macro-star
;; dummy-module
cj-standarddeclares
cj-env-1
;; mydb top
config
;; lib/mod/ :
mod/config-example
mod/gambit
mod/imperative-load-tree
mod/lib
mod/mod
mod/monad
mod/monadic-load-tree
mod/remote
mod/usersyntax))
(define (path-string.relation p relation)
(let ((form (call-with-input-file p read))
(mname (path-string.modulename p)))
(let rec ((form form))
(cond
;; `(require . `rest)
((and (pair? form)
(eq? (car form) 'require))
(relation mname
(map require-decl.modulename (cdr form))))
;; `(quote `q)
((and (pair? form)
(eq? (car form) 'quote)
(pair? (cdr form))
(null? (cddr form)))
(rec (cadr form)))
(else
(if (or (require:include? mname)
(memq mname modules-without-require-forms))
(relation mname '())
(error "file does not have a require form as its first form:"
p)))))))
;; tests see in require-util.scm