/[gcl]/gcl/cmpnew/cmpmain.lsp
ViewVC logotype

Diff of /gcl/cmpnew/cmpmain.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16 by mjthomas, Fri Oct 11 07:48:54 2002 UTC revision 1.17 by camm, Mon Nov 11 03:43:06 2002 UTC
# Line 82  Line 82 
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.
# Line 145  Line 149 
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*)
# Line 694  SYSTEM_SPECIAL_INIT Line 698  SYSTEM_SPECIAL_INIT
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)))
# Line 732  SYSTEM_SPECIAL_INIT Line 773  SYSTEM_SPECIAL_INIT
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)))
# Line 742  SYSTEM_SPECIAL_INIT Line 785  SYSTEM_SPECIAL_INIT
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))

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26