driver.scm (9679B)
1 ;;;; driver.scm - compiler-invocation 2 3 4 (define dropped '()) 5 (define defined '()) 6 (define assigned '()) 7 (define referenced '()) 8 (define undefined '()) 9 (define used-sections '()) 10 (define default-xref-mode #f) 11 12 13 (define (spock-help) 14 (display "(spock OPTION | FILENAME-OR-PORT ...)\n\n") 15 (display " Available options:\n\n") 16 (display " 'source show source forms\n") 17 (display " 'expand show forms after macro-expansion\n") 18 (display " 'canonicalized show forms after canonicalization\n") 19 (display " 'optimized show forms after optimization\n") 20 (display " 'cps show forms after CPS-conversion\n") 21 (display " 'strict enable strict mode\n") 22 (display " 'optimize enable optimizations\n") 23 (display " 'block enable block-compilation\n") 24 (display " 'library-path [DIR] add DIR to library path or return library path\n") 25 (display " 'namespace VAR put globals into module\n") 26 (display " 'xref show cross-reference\n") 27 (display " 'runtime include runtime-system in generated code\n") 28 (display " 'library compile runtime library\n") 29 (display " 'seal wrap toplevel definitions into local scope\n") 30 (display " 'debug enable debug-mode\n") 31 (display " 'usage PROC invoke PROC on usage-errors\n") 32 (display " 'fail PROC invoke PROC on compiler-errors\n") 33 (display " 'import FILENAME expand FILENAME\n") 34 (display " 'environment STORE provide syntactic environment\n") 35 (display " 'debug-syntax show debug-output during expansion\n") 36 (display " 'verbose show diagnostic messages\n") 37 (display " 'prepare just prepare state without compiling\n") 38 (display " 'code EXP code to be compiled instead of file\n") 39 (display " 'bind FILENAME generate bindings from specifications\n") 40 (display " 'output-file FILENAME specify output-file\n")) 41 42 (define (spock . args) 43 (let ((output-file #f) 44 (include-runtime #f) 45 (extract-library #f) 46 (seal-toplevel #f) 47 (files '()) 48 (mstore #f) 49 (code #f) 50 (prepare #f) 51 (optimize-mode #f) 52 (mstore-given #f) 53 (strict-mode #f) 54 (block-mode #f) 55 (debug-mode #f) 56 (xref-mode default-xref-mode) 57 (verbose-mode #f) 58 (debug-syntax #f) 59 (bindings '()) 60 (fail error) 61 (namespace #f) 62 (imports '()) 63 (show '())) 64 (define (usage opts) 65 (fail "unrecgnized option or missing argument" opts)) 66 (define (sexpand exp dbg) 67 (match-let (((exp . store) 68 (expand-syntax exp fail mstore (and dbg debug-syntax)))) 69 (set! mstore store) 70 exp)) 71 (define (compile-files state files show) 72 (let ((forms 73 (or code 74 `(begin 75 ,@(map 76 read-forms 77 (note #f state files "reading source")))))) 78 (if (memq 'source show) 79 (pp forms) 80 (let ((forms 81 (sexpand 82 (note #f state forms "expanding syntax") 83 #t))) 84 (if (memq 'expand show) 85 (pp forms) 86 (let ((forms 87 (canonicalize 88 forms 89 (note #f state state "canonicalizing")))) 90 (cond ((memq 'canonicalized show) 91 (pp forms)) 92 ((and block-mode (report-undefined))) 93 ((memq 'xref show) 94 (xref #t (note #f state #t "cross-referencing"))) 95 (else 96 (let ((forms (if optimize-mode 97 (optimize 98 forms 99 (note #f state state "optimizing")) 100 forms))) 101 (if (and optimize-mode (memq 'optimized show)) 102 (pp forms) 103 ;;XXX if "-runtime" + "-library": 104 ;; xref and add compiled library.scm 105 ;; of used definitions (sort sections topologically 106 ;; to determine order) 107 (let ((toplambdas 108 (cps 109 (note #f state forms "performing CPS conversion")))) 110 (if (memq 'cps show) 111 (for-each pp toplambdas) 112 (begin 113 (note 114 #f state 115 (generate-header state) 116 "generating code") 117 (generate-code toplambdas state) 118 (generate-trailer state))) 119 mstore))))))))))) 120 (call-with-current-continuation 121 (lambda (return) 122 (let loop ((args args)) 123 (match args 124 (() (let ((files (reverse files)) 125 (state `((strict . ,strict-mode) 126 (debug . ,debug-mode) 127 (xref . ,xref-mode) 128 (seal . ,seal-toplevel) 129 (block . ,block-mode) 130 (optimize . ,optimize-mode) 131 (verbose . ,verbose-mode) 132 (fail . ,fail) 133 (runtime . ,include-runtime) 134 (library-path . ,library-path) 135 (namespace . ,namespace)))) 136 (when (and (not mstore-given) extract-library) 137 (set! files 138 (cons 139 (read-library state "library.scm" (lambda (x) x)) 140 files))) 141 (when (and (not prepare) (null? files) (not code) (null? bindings)) 142 (fail "nothing to compile")) 143 (when (not mstore-given) 144 (sexpand 145 (let ((m (cond (strict-mode '(default strict)) 146 (debug-mode '(default debug)) 147 (else '(default))))) 148 `(define-syntax define-library-section 149 (letrec-syntax 150 ((walk 151 (syntax-rules ,m 152 ((_ ()) (%void)) 153 ,@(map (lambda (m) 154 `((_ ((,m def ...) . more)) 155 (begin def ...))) 156 m) 157 ((_ (clause . more)) 158 (walk more))))) 159 (syntax-rules () 160 ((_ sec clause ...) 161 (begin 162 (walk (clause ...)))))))) 163 #f) 164 (let ((features '(spock alexpander srfi-0 srfi-46))) 165 (when debug-mode (set! features (cons 'debug features))) 166 (when strict-mode (set! features (cons 'strict features))) 167 ;;XXX do this in a modular and extensible manner 168 (sexpand 169 `(define-syntax cond-expand 170 (syntax-rules (and or not else ,@features) 171 ((cond-expand) (syntax-error "no matching `cond-expand' clause")) 172 ,@(map (lambda (f) 173 `((cond-expand (,f body ...) . more-clauses) 174 (begin body ...))) 175 features) 176 ((cond-expand (else body ...)) (begin body ...)) 177 ((cond-expand ((and) body ...) more-clauses ...) (begin body ...)) 178 ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...) 179 (cond-expand 180 (req1 (cond-expand 181 ((and req2 ...) body ...) 182 more-clauses ...)) 183 more-clauses ...)) 184 ((cond-expand ((or) body ...) more-clauses ...) 185 (cond-expand more-clauses ...)) 186 ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...) 187 (cond-expand 188 (req1 (begin body ...)) 189 (else 190 (cond-expand 191 ((or req2 ...) body ...) 192 more-clauses ...)))) 193 ((cond-expand ((not req) body ...) more-clauses ...) 194 (cond-expand 195 (req (cond-expand more-clauses ...)) 196 (else body ...))) 197 ((cond-expand (feature-id body ...) more-clauses ...) 198 (cond-expand more-clauses ...)))) 199 #f)) 200 (sexpand (read-library state "syntax.scm") #f) 201 (sexpand (read-library state "library.scm") #f)) 202 (for-each 203 (lambda (bound) 204 (let ((bs (parse-bindings (read-contents bound)))) 205 (if (and (null? files) (not code)) 206 (pp bs) 207 (sexpand bs #t)) 208 bs)) 209 (reverse bindings)) 210 (for-each 211 (lambda (file) (sexpand (read-forms file) #t)) 212 (reverse imports)) 213 (cond (prepare mstore) 214 (output-file 215 (with-output-to-file output-file 216 (cut compile-files state files show))) 217 ((and (pair? bindings) (not code) (null? files)) #f) 218 (else (compile-files state files show))))) 219 (('help . _) 220 (spock-help)) 221 (('output-file out . more) 222 (set! output-file out) 223 (loop more)) 224 (('source . more) 225 (set! show (cons 'source show)) 226 (loop more)) 227 (('expand . more) 228 (set! show (cons 'expand show)) 229 (loop more)) 230 (('canonicalized . more) 231 (set! show (cons 'canonicalized show)) 232 (loop more)) 233 (('optimize . more) 234 (set! optimize-mode #t) 235 (loop more)) 236 (('optimized . more) 237 (set! optimize-mode #t) 238 (set! show (cons 'optimized show)) 239 (loop more)) 240 (('cps . more) 241 (set! show (cons 'cps show)) 242 (loop more)) 243 (('strict . more) 244 (set! strict-mode #t) 245 (loop more)) 246 (('block . more) 247 (set! block-mode #t) 248 (set! xref-mode #t) 249 (loop more)) 250 (('import filename . more) 251 (set! imports (cons filename imports)) 252 (loop more)) 253 (('bind arg . more) 254 (set! bindings (cons arg bindings)) 255 (loop more)) 256 (('library-path) 257 (return library-path)) 258 (('library-path dir . more) 259 (set! library-path (cons dir library-path)) 260 (loop more)) 261 (('namespace ns . more) 262 (set! namespace ns) 263 (loop more)) 264 (('xref . more) 265 (set! show (cons 'xref show)) 266 (set! xref-mode #t) 267 (loop more)) 268 (('runtime . more) 269 (set! include-runtime #t) 270 (set! extract-library #t) 271 (loop more)) 272 (('library . more) 273 (set! extract-library #t) 274 (loop more)) 275 (('seal . more) 276 (set! seal-toplevel #t) 277 (loop more)) 278 (('fail proc . more) 279 (set! fail proc) 280 (loop more)) 281 (('usage proc . more) 282 (set! usage proc) 283 (loop more)) 284 (('prepare . more) 285 (set! prepare #t) 286 (loop more)) 287 (('debug . more) 288 (set! debug-mode #t) 289 (loop more)) 290 (('environment store . more) 291 (set! mstore store) 292 (set! mstore-given #t) 293 (loop more)) 294 (('verbose . more) 295 (set! verbose-mode #t) 296 (loop more)) 297 (('debug-syntax . more) 298 (set! debug-syntax #t) 299 (loop more)) 300 (('code exp . more) 301 (set! code exp) 302 (loop more)) 303 (((or (? string? file) (? input-port? file)) . more) 304 (set! files (cons file files)) 305 (loop more)) 306 ((opts ...) (usage opts))))))))