Description: TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. . gcl (2.6.12-91) unstable; urgency=medium . * Version_2_6_13pre88 Author: Camm Maguire --- The information above should follow the Patch Tagging Guidelines, please checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here are templates for supplementary fields that you might want to add: Origin: , Bug: Bug-Debian: https://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: 2019-12-30 --- gcl-2.6.12.orig/cmpnew/gcl_cmpmain.lsp +++ gcl-2.6.12/cmpnew/gcl_cmpmain.lsp @@ -57,28 +57,19 @@ ;; Let the user write dump c-file etc to /dev/null. -(defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)) +(defun get-output-pathname (file ext name &optional + (dir (pathname-directory *default-pathname-defaults*)) (device (pathname-device *default-pathname-defaults*))) - (cond - ((equal file "/dev/null") (pathname file)) + (cond ((equal file "/dev/null") (pathname file)) #+aix3 ((and (equal name "float") (equal ext "h")) (get-output-pathname file ext "Float" )) - (t - (make-pathname :device (or (and (not (null file)) - (not (eq file t)) - (pathname-device file)) - device) - :directory (or (and (not (null file)) - (not (eq file t)) - (pathname-directory file)) - dir) - :name (or (and (not (null file)) - (not (eq file t)) - (pathname-name file)) - name) - :type ext)))) + ((let ((lf (and file (not (eq file t))))) + (let ((device (if lf (pathname-device file) device)) + (dir (if lf (pathname-directory file) dir)) + (name (if lf (pathname-name file) name))) + (make-pathname :device device :directory dir :name name :type ext)))))) (defun safe-system (string) (multiple-value-bind @@ -109,15 +100,7 @@ ;; will be performed for separate chunks of the lisp files. (defvar *split-files* nil) ;; if -(defun check-end (form eof) - (cond ((eq form eof) - (setf (third *split-files*) nil)) - ((> (file-position *compiler-input*) - (car *split-files*)) - (setf (third *split-files*)(file-position *compiler-input*))))) - - -(defun compile-file (&rest args +(defun compile-file (filename &rest args &aux (*print-pretty* nil) (*package* *package*) (*split-files* *split-files*) (*PRINT-CIRCLE* NIL) @@ -131,17 +114,17 @@ (*PRINT-BASE* 10) (*PRINT-ESCAPE* T) (section-length *split-files*) - tem) + tem warnings failures + (filename (pathname filename)) + (*compile-file-pathname* (merge-pathnames filename #p".lsp")) + (*compile-file-truename* (truename *compile-file-pathname*))) (loop (compiler::init-env) - (setq tem (apply 'compiler::compile-file1 args)) - (cond ((atom *split-files*)(return tem)) - ((and (consp *split-files*) - (null (third *split-files*))) - (let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args))) - (gazonk-name))) - (*readtable* (si::standard-readtable))) - (setq gaz (get-output-pathname gaz "lsp" (car args))) + (setq tem (apply 'compile-file1 filename args)) + (cond ((atom *split-files*) + (return (values (when tem (truename tem)) warnings failures))) + ((null (third *split-files*)) + (let ((gaz (gazonk-name))(*readtable* (si::standard-readtable))) (with-open-file (st gaz :direction :output) (print `(eval-when (load eval) @@ -149,16 +132,15 @@ (load (merge-pathnames v si::*load-pathname*)))) st)) (setq *split-files* nil) - (or (member :output-file args) - (setq args (append args (list :output-file (car args))))) (return - (prog1 (apply 'compile-file gaz (cdr args)) - (unless *keep-gaz* (mdelete-file gaz)))) - )) - (t nil)) - (if (consp *split-files*) - (setf (car *split-files*) (+ (third *split-files*) section-length))) - )) + (let ((tem (apply 'compile-file gaz + (append args + (unless (member :output-file args) + (list :output-file + (get-output-pathname filename "o" nil nil nil))))))) + (unless *keep-gaz* (mdelete-file gaz)) + (values (when tem (truename tem)) warnings failures))))) + ((setf (car *split-files*) (+ (third *split-files*) section-length)))))) (defun compile-file1 (input-pathname @@ -172,13 +154,14 @@ (prof-p *default-prof-p*) (print nil) (load nil) - &aux (*standard-output* *standard-output*) - (*prof-p* prof-p) + &aux + (*standard-output* *standard-output*) + (*prof-p* prof-p) + (output-file (pathname output-file)) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) - (*package* *package*) (*DEFAULT-PATHNAME-DEFAULTS* #p"") (*data* (list nil)) *init-name* @@ -211,41 +194,30 @@ Cannot compile ~a.~%" (*compiler-input* (merge-pathnames input-pathname #p".lsp")) - (cond ((numberp *split-files*) - (if (< (file-length *compiler-input*) *split-files*) - (setq *split-files* nil) - (setq *split-files* (list *split-files* nil 0 nil))))) + (when (numberp *split-files*) + (setq *split-files* (unless (< (file-length *compiler-input*) *split-files*) (list *split-files* nil 0 nil)))) - (cond ((consp *split-files*) - (file-position *compiler-input* (third *split-files*)) - (setq output-file - (make-pathname :directory (pathname-directory output-file) - :name (format nil "~a~a" (length (second *split-files*)) (pathname-name (pathname output-file))) - :type "o")) - - (push (pathname-name output-file) (second *split-files*)))) + (when (consp *split-files*) + (file-position *compiler-input* (third *split-files*)) + (setq output-file + (make-pathname :directory (pathname-directory output-file) + :name (format nil "~a~a" + (pathname-name output-file) + (length (second *split-files*))) + :type "o"))) - (let* ((eof (cons nil nil)) - (dir (or (and (not (null output-file)) - (pathname-directory output-file)) - (pathname-directory input-pathname))) - (name (or (and (not (null output-file)) - (pathname-name output-file)) - (pathname-name input-pathname))) - (device (or (and (not (null output-file)) - (pathname-device output-file)) - (pathname-device input-pathname))) - (typ (or (and (not (null output-file)) - (pathname-type output-file)) - "o")) - - (o-pathname (get-output-pathname o-file typ name dir device)) - (c-pathname (get-output-pathname c-file "c" name dir device)) - (h-pathname (get-output-pathname h-file "h" name dir device)) - (data-pathname (get-output-pathname data-file "data" name dir device))) + (let* ((eof (cons nil nil)) + (dir (pathname-directory (or output-file input-pathname))) + (name (pathname-name (or output-file input-pathname))) + (device (pathname-device (or output-file input-pathname))) + (typ (pathname-type (or output-file #p".o"))) + (o-pathname (get-output-pathname o-file typ name dir device)) + (c-pathname (get-output-pathname c-file "c" name dir device)) + (h-pathname (get-output-pathname h-file "h" name dir device)) + (data-pathname (get-output-pathname data-file "data" name dir device))) - (declare (special dir name )) + (declare (special dir name)) (init-env) @@ -278,21 +250,32 @@ Cannot compile ~a.~%" (setq prev nil)) ;; t1expr the package ops again.. - (if (consp *split-files*) - (dolist (v (fourth *split-files*)) (t1expr v))) + (when (consp *split-files*) + (dolist (v (fourth *split-files*)) (t1expr v))) + (unwind-protect (do ((form (read *compiler-input* nil eof)(read *compiler-input* nil eof)) - (load-flag (if *eval-when-defaults* (member 'load *eval-when-defaults*) t))) + (load-flag (if *eval-when-defaults* + (or (member 'load *eval-when-defaults*) + (member :load-toplevel *eval-when-defaults*)) + t))) (nil) - (cond - ((eq form eof)) - (load-flag (t1expr form)) - ((maybe-eval nil form))) - (cond - ((and *split-files* (check-end form eof)) - (setf (fourth *split-files*) nil);(reverse (third *data*)) ;FIXME check this - (return nil)) - ((eq form eof) (return nil)))) + + (unless (eq form eof) + (if load-flag + (t1expr form) + (maybe-eval nil form))) + + (when (or (eq form eof) + (when *split-files* + (> (file-position *compiler-input*) (car *split-files*)))) + + (when *split-files* + (push (pathname-name output-file) (second *split-files*)) + (setf (third *split-files*) (unless (eq form eof) (file-position *compiler-input*))) + (setf (fourth *split-files*) nil));(reverse (third *data*)) ;FIXME check this + + (return nil))) (when prev (set-dispatch-macro-character #\# #\, prev rtb))))) @@ -331,7 +314,7 @@ Cannot compile ~a.~%" (unless c-file (mdelete-file c-pathname)) (unless h-file (mdelete-file h-pathname)) (unless (or data-file #+ld-not-accept-data t system-p) (mdelete-file data-pathname)) - o-pathname) + (when o-file o-pathname)) (progn (when (probe-file c-pathname) (mdelete-file c-pathname)) @@ -339,8 +322,7 @@ Cannot compile ~a.~%" (when (probe-file data-pathname) (mdelete-file data-pathname)) (format t "~&No FASL generated.~%") (setq *error-p* t) - (values) - )))))) + (values)))))) (defun gazonk-name () (dotimes (i 1000)