82 |
;; is :system-p we use it on all files. If nil use it on none. |
;; is :system-p we use it on all files. If nil use it on none. |
83 |
(defvar *fasd-data* t) |
(defvar *fasd-data* t) |
84 |
(defvar *data* nil) |
(defvar *data* nil) |
85 |
|
(defvar *default-system-p* nil) |
86 |
|
(defvar *default-c-file* nil) |
87 |
|
(defvar *default-h-file* nil) |
88 |
|
(defvar *default-data-file* nil) |
89 |
|
|
90 |
;; (list section-length split-file-names next-section-start-file-position) |
;; (list section-length split-file-names next-section-start-file-position) |
91 |
;; Many c compilers cannot handle the large C files resulting from large lisp files. |
;; Many c compilers cannot handle the large C files resulting from large lisp files. |
149 |
(defun compile-file1 (input-pathname |
(defun compile-file1 (input-pathname |
150 |
&key (output-file input-pathname) |
&key (output-file input-pathname) |
151 |
(o-file t) |
(o-file t) |
152 |
(c-file nil) |
(c-file *default-c-file*) |
153 |
(h-file nil) |
(h-file *default-h-file*) |
154 |
(data-file nil) |
(data-file *default-data-file*) |
155 |
(c-debug nil) |
(c-debug nil) |
156 |
#+aosvs (ob-file nil) |
#+aosvs (ob-file nil) |
157 |
(system-p nil) |
(system-p *default-system-p*) |
158 |
(print nil) |
(print nil) |
159 |
(load nil) |
(load nil) |
160 |
&aux (*standard-output* *standard-output*) |
&aux (*standard-output* *standard-output*) |
698 |
|
|
699 |
(setq tem (concatenate 'string out ".c")) |
(setq tem (concatenate 'string out ".c")) |
700 |
(with-open-file (st tem :direction :output) |
(with-open-file (st tem :direction :output) |
701 |
(format st "#include ~a~%" *cmpinclude*) |
(format st "#include <string.h>~%") |
702 |
(format st "#define init_or_load(fn,file) do {extern void fn(void); init_or_load1(fn,file);} while(0)~%") |
(format st "#include ~a~%~%" *cmpinclude*) |
703 |
(format st "object user_init() {~%") |
|
704 |
(dolist (tem files) |
(format st "#define load2(a) do {") |
705 |
(cond ((equal (pathname-type tem) "o") |
(format st "printf(\"Loading %s...\\n\",(a));") |
706 |
(format st "init_or_load(init_~a,\"~a\");~%" |
(format st "load(a);") |
707 |
(substitute #\_ #\- (pathname-name tem)) tem)) |
(format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") |
708 |
(t |
|
709 |
(format st "load(\"~a\");~%" tem)))) |
(let ((p nil)) |
710 |
(format st "return Cnil;}~%") |
(dolist (tem files) |
711 |
) |
(when (equal (pathname-type tem) "o") |
712 |
|
(push (list (substitute #\_ #\- (pathname-name tem)) tem) p))) |
713 |
|
|
714 |
|
(setq p (nreverse p)) |
715 |
|
|
716 |
|
(dolist (tem p) |
717 |
|
(format st "extern void init_~a(void);~%" (car tem))) |
718 |
|
(format st "~%") |
719 |
|
|
720 |
|
(format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") |
721 |
|
(format st "#define NF ~a~%" (length p)) |
722 |
|
(format st "static Fnlst my_fnlst[NF]={") |
723 |
|
(dolist (tem p) |
724 |
|
(when (not (eq tem (car p))) |
725 |
|
(format st ",~%")) |
726 |
|
(format st "{init_~a,\"~a\"}" (car tem) (cadr tem))) |
727 |
|
(format st "};~%~%") |
728 |
|
|
729 |
|
(format st "object user_init(void) {~%") |
730 |
|
(dolist (tem files) |
731 |
|
(cond ((equal (cadr (car p)) tem) |
732 |
|
(format st "init_or_load1(init_~a,\"~a\");~%" (car (car p)) (cadr (car p))) |
733 |
|
(setq p (cdr p))) |
734 |
|
(t |
735 |
|
(format st "load2(\"~a\");~%" tem)))) |
736 |
|
(format st "return Cnil;}~%~%") |
737 |
|
|
738 |
|
(format st "int user_match(const char *s,int n) {~%") |
739 |
|
(format st " const Fnlst *f;~%") |
740 |
|
(format st " for (f=my_fnlst;f<my_fnlst+NF;f++){~%") |
741 |
|
(format st " if (!strncmp(s,f->s,n)) {~%") |
742 |
|
(format st " init_or_load1(f->fn,f->s);~%") |
743 |
|
(format st " return 1;~%") |
744 |
|
(format st " }~%") |
745 |
|
(format st " }~%") |
746 |
|
(format st " return 0;~%") |
747 |
|
(format st "}~%~%"))) |
748 |
|
|
749 |
(system (format nil "~a ~a" *cc* tem)) |
(system (format nil "~a ~a" *cc* tem)) |
750 |
(delete-file tem) |
(delete-file tem) |
751 |
|
|
752 |
) |
) |
753 |
|
|
754 |
(defun link (files image &optional post extra-libs &aux raw init) |
(defun link (files image &optional post extra-libs (run-user-init t) &aux raw init) |
755 |
|
|
756 |
(make-user-init files "user-init") |
(make-user-init files "user-init") |
757 |
(setq raw (format nil "raw_~a" (pathname-name image))) |
(setq raw (format nil "raw_~a" (pathname-name image))) |
773 |
(delete-file "user-init.o") |
(delete-file "user-init.o") |
774 |
|
|
775 |
(with-open-file (st init :direction :output) |
(with-open-file (st init :direction :output) |
776 |
|
(unless run-user-init |
777 |
|
(format st "(fmakunbound 'si::user-init)~%")) |
778 |
(format st "(setq si::*no-init* '(") |
(format st "(setq si::*no-init* '(") |
779 |
(dolist (tem files) |
(dolist (tem files) |
780 |
(format st " \"~a\"" (pathname-name tem))) |
(format st " \"~a\"" (pathname-name tem))) |
785 |
(if (stringp post) (format st "~a~%" post)) |
(if (stringp post) (format st "~a~%" post)) |
786 |
(format st "(si::save-system \"~a\")~%" image)) |
(format st "(si::save-system \"~a\")~%" image)) |
787 |
|
|
788 |
(system (format nil "~a ~a < ~a" |
(system (format nil "./~a ~a < ~a" |
789 |
raw |
raw |
790 |
si::*system-directory* |
si::*system-directory* |
791 |
init)) |
init)) |