diff --git a/src/cmp/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx.lsp index 74f5f38f7..2cea0f2b1 100644 --- a/src/cmp/cmpbackend-cxx.lsp +++ b/src/cmp/cmpbackend-cxx.lsp @@ -530,8 +530,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS ;;; Code generation -(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name - &key input-designator) +(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source) (setq *compiler-phase* 't2) (with-open-file (*compiler-output1* c-pathname :direction :output @@ -544,7 +543,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS (declare (ignore second)) (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) - (wt-comment-nl "Source: ~A" input-designator) + (wt-comment-nl "Source: ~A" source) (with-open-file (*compiler-output2* h-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) @@ -554,6 +553,32 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS (terpri *compiler-output2*))) (data-c-dump data-pathname)) +(defun compiler-pass/assemble-cxx (input-file output-file + &key + (c-file nil) + (h-file nil) + (data-file nil) + (system-p nil) + &allow-other-keys) + (let* ((cpath (compile-file-pathname output-file :output-file c-file :type :c)) + (hpath (compile-file-pathname output-file :output-file h-file :type :h)) + (dpath (compile-file-pathname output-file :output-file data-file :type :data)) + (opath (compile-file-pathname output-file :type :object)) + (to-delete (nconc (unless c-file (list cpath)) + (unless h-file (list hpath)) + (unless data-file (list dpath)) + (unless system-p (list opath)))) + (init-name (compute-init-name output-file :kind (if system-p :object :fasl)))) + (compiler-pass/generate-cxx cpath hpath dpath init-name input-file) + (if system-p + (compiler-cc cpath opath) + (progn + (compiler-cc cpath opath) + (bundle-cc (brief-namestring output-file) + init-name + (list (brief-namestring opath))))) + (mapc 'cmp-delete-file to-delete))) + ;;; The builder. diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index a3641632e..b9673b447 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -20,12 +20,11 @@ (in-package "COMPILER") -(defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p) - verbose print c-file h-file data-file - system-p load external-format source-truename - source-offset) - (declare (ignore verbose print c-file h-file data-file load - external-format source-truename source-offset)) +(defun compile-file-pathname (name &key + (output-file T) + (type nil type-supplied-p) + (system-p nil) + &allow-other-keys) (let* ((format '()) (extension '())) (unless type-supplied-p @@ -76,14 +75,15 @@ (ext:*source-location* (cons source-truename 0)) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*)))) - (declare (notinline compiler-cc)) + (declare (notinline compiler-cc) + (ignorable c-file h-file data-file)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then \".lsp\" is used as the default file type for the source file. LOAD specifies whether to load the generated fasl file after compilation. The :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to control the intermediate files generated by the ECL compiler.If the file was -compiled successfully, returns the pathname of the compiled file" +compiled successfully, returns the pathname of the compiled file." #-dlopen (unless system-p (format t "~%;;;~ @@ -105,47 +105,23 @@ compiled successfully, returns the pathname of the compiled file" (let* ((input-file (truename *compile-file-pathname*)) (*compile-file-truename* input-file) (*compiler-in-use* *compiler-in-use*) - (*load-time-values* nil) ;; Load time values are compiled - (output-file (apply #'compile-file-pathname input-file - :output-file output-file args)) - (true-output-file nil) ;; Will be set at the end - (c-pathname (apply #'compile-file-pathname output-file :output-file c-file - :type :c args)) - (h-pathname (apply #'compile-file-pathname output-file :output-file h-file - :type :h args)) - (data-pathname (apply #'compile-file-pathname output-file - :output-file data-file :type :data args)) - (compiler-conditions nil) - (to-delete (nconc (unless c-file (list c-pathname)) - (unless h-file (list h-pathname)) - (unless data-file (list data-pathname)))) - (init-name (compute-init-name output-file - :kind (if system-p :object :fasl)))) + (*load-time-values* nil) ; Load time values are compiled. + (output-file (apply #'compile-file-pathname input-file :output-file output-file args)) + (true-output-file nil) ; Will be set at the end. + (compiler-conditions nil)) (with-compiler-env (compiler-conditions) (print-compiler-info) (when (probe-file "./cmpinit.lsp") (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (with-open-file (stream *compile-file-pathname* - :external-format external-format) + (with-open-file (stream *compile-file-pathname* :external-format external-format) (unless source-truename (setf (car ext:*source-location*) *compile-file-pathname*)) (compiler-pass1 stream source-offset)) (compiler-pass/propagate-types) - (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name - :input-designator (namestring input-pathname)) - (if system-p - (compiler-cc c-pathname output-file) - (let ((o-pathname (compile-file-pathname output-file :type :object))) - (compiler-cc c-pathname o-pathname) - (push o-pathname to-delete) - (bundle-cc (brief-namestring output-file) - init-name - (list (brief-namestring o-pathname))))) + (apply #'compiler-pass/assemble-cxx input-file output-file args) (if (setf true-output-file (probe-file output-file)) - (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" - (namestring input-pathname)) + (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname)) (cmperr "The C compiler failed to compile the intermediate file.")) - (mapc #'cmp-delete-file to-delete) (when load (load true-output-file :verbose *compile-verbose*))) ; with-compiler-env (compiler-output-values true-output-file compiler-conditions))) @@ -224,12 +200,7 @@ after compilation." (let* ((*load-time-values* 'values) ;; Only the value is kept (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) - (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) + (so-pathname (compile-file-pathname (first tmp-names))) (compiler-conditions nil) (*permanent-data* t) ; needed for literal objects in closures (*cmp-env-root* *cmp-env-root*)) @@ -239,18 +210,7 @@ after compilation." (compiler-pass1 form) (compiler-pass/propagate-types) (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) - (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name - :input-designator (let* ((*print-circle* t) - (*print-length* 8) - (*print-depth* 4)) - (format nil "~W" def)))) - (compiler-cc c-pathname o-pathname) - (bundle-cc (brief-namestring so-pathname) - init-name - (list (brief-namestring o-pathname))) - (cmp-delete-file c-pathname) - (cmp-delete-file h-pathname) - (cmp-delete-file o-pathname) + (compiler-pass/assemble-cxx nil so-pathname)) (mapc 'cmp-delete-file tmp-names) (cond ((probe-file so-pathname) (load so-pathname :verbose nil) @@ -260,10 +220,6 @@ after compilation." (set 'GAZONK nil) (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) ) ; with-compiler-env - (cmp-delete-file c-pathname) - (cmp-delete-file h-pathname) - (cmp-delete-file so-pathname) - (mapc 'cmp-delete-file tmp-names) (let ((output (or name (and (boundp 'GAZONK) (symbol-value 'GAZONK)) #'(lambda (&rest x) (declare (ignore x)) @@ -293,24 +249,24 @@ disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form. H-FILE and DATA-FILE specify intermediate files to build a fasl file from the C language code. NIL means \"do not create the file\"." - (when (si::valid-function-name-p thing) + (when (si:valid-function-name-p thing) (setq thing (fdefinition thing))) (when (and (functionp thing) (function-lambda-expression thing)) (multiple-value-setq (thing lexenv) (function-lambda-expression thing)) (when (eq lexenv t) - (warn "DISASSEMBLE can not disassemble C closures") + (warn "DISASSEMBLE can not disassemble C closures.") (return-from disassemble nil))) (cond ((null thing)) ((functionp thing) - (unless (si::bc-disassemble thing) + (unless (si:bc-disassemble thing) (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) (return-from disassemble nil))) ((atom thing) (error 'simple-type-error :datum thing :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" + :format-control "DISASSEMBLE cannot accept ~A." :format-arguments (list thing))) ((eq (car thing) 'LAMBDA) (setq disassembled-form `(defun gazonk ,@(cdr thing)))) @@ -320,7 +276,7 @@ from the C language code. NIL means \"do not create the file\"." (error 'simple-type-error :datum thing :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" + :format-control "DISASSEMBLE cannot accept ~A." :format-arguments (list thing)))) (let* ((null-stream (make-broadcast-stream)) @@ -358,8 +314,8 @@ from the C language code. NIL means \"do not create the file\"." (if (streamp object) (do* ((eof '(NIL)) (*compile-file-position* 0 (file-position object)) - (form (si::read-object-or-ignore object eof) - (si::read-object-or-ignore object eof))) + (form (si:read-object-or-ignore object eof) + (si:read-object-or-ignore object eof))) ((eq form eof)) (when form (setf (cdr ext:*source-location*) @@ -395,12 +351,12 @@ from the C language code. NIL means \"do not create the file\"." (compile-file #'compile-file) (compile-file-pathname #'compile-file-pathname)) (defun ext:install-c-compiler () - (ext::package-lock (find-package :cl) nil) + (ext:package-lock (find-package :cl) nil) (setf *features* (delete :ecl-bytecmp *features*)) (setf (fdefinition 'disassemble) disassemble (fdefinition 'compile) compile (fdefinition 'compile-file) compile-file (fdefinition 'compile-file-pathname) compile-file-pathname) - (ext::package-lock (find-package :cl) t))) + (ext:package-lock (find-package :cl) t))) (provide 'cmp)