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
|
(in-package 'compiler)
(defun make-user-init (files outn)
(let* ((c (pathname outn))
(c (merge-pathnames c (make-pathname :directory '(:current))))
(o (merge-pathnames (make-pathname :type "o") c))
(c (merge-pathnames (make-pathname :type "c") c)))
(with-open-file (st c :direction :output)
(format st "#include ~a~%~%" *cmpinclude*)
(format st "#define load2(a) do {")
(format st "printf(\"Loading %s...\\n\",(a));")
(format st "load(a);")
(format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%")
(let ((p nil))
(dolist (tem files)
(when (equal (pathname-type tem) "o")
(let ((tem (namestring tem)))
(push (list (si::find-init-name tem) tem) p))))
(setq p (nreverse p))
(dolist (tem p)
(format st "extern void ~a(void);~%" (car tem)))
(format st "~%")
(format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%")
(format st "#define NF ~a~%" (length p))
(format st "static Fnlst my_fnlst[NF]={")
(dolist (tem p)
(when (not (eq tem (car p)))
(format st ",~%"))
(format st "{~a,\"~a\"}" (car tem) (cadr tem)))
(format st "};~%~%")
(format st "static int user_init_run;~%")
(format st "#define my_load(a_,b_) {if (!user_init_run && (a_)) gcl_init_or_load1((a_),(b_));(a_)=0;}~%~%")
(format st "object user_init(void) {~%")
(format st "user_init_run=1;~%")
(dolist (tem files)
(let ((tem (namestring tem)))
(cond ((equal (cadr (car p)) tem)
(format st "gcl_init_or_load1(~a,\"~a\");~%"
(car (car p)) tem)
(setq p (cdr p)))
(t
(format st "load2(\"~a\");~%" tem)))))
(format st "return Cnil;}~%~%")
(format st "int user_match(const char *s,int n) {~%")
(format st " Fnlst *f;~%")
(format st " for (f=my_fnlst;f<my_fnlst+NF;f++){~%")
(format st " if (!strncmp(s,f->s,n)) {~%")
(format st " my_load(f->fn,f->s);~%")
(format st " return 1;~%")
(format st " }~%")
(format st " }~%")
(format st " return 0;~%")
(format st "}~%~%")))
(compiler-cc c o)
; (system (format nil "~a ~a" *cc* tem))
; (with-open-file (s c) (si::copy-stream s *standard-output*))
(delete-file c)
o))
(setq *default-system-p* t)
(in-package 'user)
(delete :native-reloc *features*)
|
