1;; -*- Scheme -*- 2#!read-macro=sagittarius/regex 3(import (rnrs) 4 (rnrs eval) 5 (sagittarius cgen precomp) 6 (sagittarius regex) 7 (sagittarius control) 8 (sagittarius compiler procedure) 9 (sagittarius vm) 10 (sagittarius aspect) 11 (util file) 12 (match) 13 (getopt) 14 (util port) 15 (pp) 16 (srfi :1) 17 (srfi :13) 18 (srfi :26) 19 (srfi :39)) 20 21;; cancel inliner 22(procedure-inliner-set! (find-procedure 'map '(core base)) #f) 23(procedure-inliner-set! (find-procedure 'for-each '(core base)) #f) 24 25(define-constant +default-compiler+ "../boot/compiler.scm") 26;; import specs for compiler 27;; we can use (rnrs) here since it won't be pre-compiled 28;; ****CAUTION**** 29;; DO NOT USE INLINED PROCEDURES SUCH AS map AND for-each 30;; So basically we can't use (rnrs) 31(define-constant +default-imports+ '((except (core) er-rename) 32 (except (core base) er-rename) 33 (core syntax) 34 (except (core macro) 35 BOUNDARY 36 LEXICAL .list) 37 (core errors) 38 (core misc) 39 (rename (match) (match smatch)) 40 (except (sagittarius) er-rename) 41 (sagittarius vm) 42 (sagittarius vm debug) 43 (sagittarius vm instruction) 44 (sagittarius fixnums) 45 (sagittarius compiler util) 46 (sagittarius compiler procedure))) 47(define-constant +default-includes+ '("../boot")) 48 49(define-constant +targets-file+ "genlib.targets") 50 51(define *features* (make-parameter '(sagittarius sagittarius.scheme.vm))) 52 53(define-syntax parse-options 54 (syntax-rules () 55 ((_ options ((name mark default) ...) body ...) 56 (let ((name (cond ((assq 'mark options) => cdr) (else default))) 57 ...) 58 body ...)))) 59 60(define (load-compiler options) 61 (parameterize ((*features* '(sagittarius))) 62 (parse-options options 63 ((compiler compiler +default-compiler+) 64 (libs compiler-import +default-imports+) 65 (includes includes +default-includes+)) 66 (let1 form (construct-library-form 67 compiler `((library . (sagittarius host compiler)) 68 (exports compile) 69 (imports . ,libs) 70 (includes . ,includes))) 71 (eval form (environment '(only (sagittarius) library) 72 'user)) 73 (find-procedure 'compile '(sagittarius host compiler)))))) 74 75(define (name-generator filename libname) 76 (define (path-directory filename) 77 (let-values (((dir base ext) (decompose-path filename))) dir)) 78 (let-values (((out-file initfun-name) 79 (default-name-generator filename libname))) 80 (let* ((dir (string-split (path-directory filename) #/[\/\\]/)) 81 ;; FIXME currently we are using ../boot/... but 82 ;; for future we might move 83 (targets (drop dir 2)) 84 (base (string-join targets "_"))) 85 (values (string-append base (if (zero? (string-length base)) 86 "" "_") out-file) 87 initfun-name)))) 88 89(define-syntax aif 90 (lambda (x) 91 (syntax-case x () 92 ((aif expr then else) 93 (with-syntax ((it (datum->syntax #'aif 'it))) 94 #'(let ((it expr)) 95 (if it then else))))))) 96 97(define (resolve-cond-expand&include forms loadpaths) 98 (define marks (*features*)) 99 (define (find-file base loadpaths) 100 (car (filter-map (lambda (dir) 101 (let1 f (build-path dir base) 102 (and (file-exists? f) f))) loadpaths))) 103 (define (handle-cond-expand body form) 104 (aif (find (lambda (x) (memq (car x) marks)) body) 105 (resolve-include (cdr it)) 106 (aif (find (lambda (x) (eq? (car x) 'else)) body) 107 `(begin ,@(resolve-include (cdr it))) 108 (error 'cond-expand "unfulfileld cond-expand" form)))) 109 (define (resolve-include forms) 110 (map (lambda (form) 111 (match form 112 (('include file) 113 `(begin ,@(map (lambda (sexp) 114 (match sexp 115 (('cond-expand . body) 116 `(begin ,@(handle-cond-expand body sexp))) 117 (_ sexp))) 118 (file->sexp-list (find-file file loadpaths))))) 119 (_ form))) forms)) 120 (map (lambda (form) 121 (match form 122 (('cond-expand . body) 123 `(begin ,@(handle-cond-expand body form))) 124 (('include . path) 125 `(begin ,@(resolve-include (list form)))) 126 (_ form))) forms)) 127 128(define (construct-library-form file options) 129 (define (rename-if-needed n libs) 130 (match n 131 (('for name bogus ...) 132 (cond ((assoc name libs) => (lambda (s) (cons* 'for (cdr s) bogus))) 133 (else n))) 134 (else 135 (cond ((assoc n libs) => cdr) 136 (else n))))) 137 (define (resolve-additionals additionals) 138 (define (resolve-additional add) 139 (let* ((base (path-sans-extension (path-basename add))) 140 (name (list (string->symbol base))) 141 (libname (string->symbol (string-append +replace-prefix+ base))) 142 (form (construct-library-form 143 add `((library . ,libname) 144 (imports (except (rnrs) syntax-rules) 145 (sagittarius) 146 (only (compat r7rs) syntax-rules)))))) 147 (eval form (environment '(sagittarius))) 148 (cons name libname))) 149 (map resolve-additional additionals)) 150 151 (parse-options options 152 ((lib library (error 'genlib "library name is missing")) 153 (imports imports (error 'genlib "import library is missing")) 154 (oexports exports #f) 155 (additionals additionals '()) 156 (includes includes '())) 157 ;; for now just add 158 (let* ((sexp (file->sexp-list file)) 159 (enums '()) 160 (exports 161 (filter-map (lambda (sexp) 162 (match sexp 163 (('define (name . args) expr ...) name) 164 (('define (? symbol? name) expr) name) 165 (('define-constant (? symbol? name) expr) name) 166 (('define-syntax name expr) name) 167 ;; fxxk!!! 168 (('define-enum name . e*) 169 (set! enums (append e* enums)) 170 name) 171 (else #f))) sexp))) 172 ;; try not to contaminate the existing library. 173 (let* ((libs (resolve-additionals additionals)) 174 (form `(library ,lib 175 (export ,@(if oexports 176 oexports 177 (reverse (append exports enums)))) 178 (import ,@(map (cut rename-if-needed <> libs) imports)) 179 ,@(resolve-cond-expand&include sexp includes)))) 180 form)))) 181 182(define (check-timestamp scm-file out-file) 183 (not 184 (and (file-exists? out-file) 185 ;; check the timestamp 186 (let ((target-mtime (file-stat-mtime scm-file)) 187 (precomp-mtime (file-stat-mtime out-file))) 188 (and (< target-mtime precomp-mtime) 189 (print "generated file id older than target file. " 190 out-file)))))) 191 192 193(define (gen clean? force?) 194 (define compiler #f) 195 (define (do-clean file libname) 196 (let ((filename (name-generator file libname))) 197 (when (file-exists? filename) (delete-file filename)))) 198 (define (get-form/libname config) 199 (if (assq 'construct config) 200 (values #f (get-library-name config)) 201 (let* ((file (cdr (assq 'file config))) 202 (form (call-with-input-file file read))) 203 (values form (cadr form))))) 204 (define (get-library-name options) 205 (parse-options options 206 ((lib library (error 'genlib "library name is missing"))) 207 lib)) 208 (call-with-input-file +targets-file+ 209 (lambda (in) 210 (port-for-each 211 (lambda (config) 212 (let-values (((file) (cdr (assq 'file config))) 213 ((form libname) (get-form/libname config))) 214 (if clean? 215 (print "cleaning generated file from: " file) 216 (print "generating from file:" file)) 217 (if clean? 218 (do-clean file libname) 219 (let () 220 ;; clean needs to be done no matter what 221 (when (or force? 222 (check-timestamp file (name-generator file libname))) 223 (unless compiler 224 (set! compiler (load-compiler config))) 225 (cgen-precompile 226 (or form 227 (construct-library-form file config)) 228 :in-file file 229 :name-generator name-generator 230 :predef-syms '(LIBSAGITTARIUS_BODY) 231 :compiler compiler)))))) 232 (lambda () (read in)))))) 233(define (main args) 234 (with-args (cdr args) 235 ((clean? (#\c "clean") #f #f) 236 (force? (#\f "force") #f #f)) 237 (gen clean? force?))) 238