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